Управление списком баз 1С - обновление

Увы, требуют переходить на 1С 8.3, в связи с этим, пришлось внести коррективы в логику работы скрипта.  

Что поменялось:

1. Названия групп AD теперь должны начинаться с ConnectDB_1C_v8, предыдущие ConnectDB_1C_82 оставлены для обратной совместимости, что бы не переименовывать группы. Соответственно, поскольку что для 8.2, что для 8.3 сам механизм хранения настроек не поменялся, версия подключенной базы зависит только от того, что прописано в .v8i файле. Если есть одни и те же базы, но в разных версиях и они должны существовать параллельно, то можно:
1. Назвать группу ConnectDB_1C_v8.X, скрипт считывает только первые 18 символов в имени(Имя группы выглядит CN=ConnectDB_1C_v8).
2. Прописать в .v8i файле все версии баз.
2. Добавлена проверка на наличие установленной 1С 8.3, такая же примитивная, что и раньше(существование папки 1cv8 в ProgramFiles\ProgramFiles(x86) ).
3. Добавлена проверка на наличие файла 1CEStart.cfg, при его отсутствии - создание. Без этой проверки, если файла не было - базы не прописывались.

Сам скрипт(v2):

On Error Resume Next 

Const PROPERTY_NOT_FOUND  = &h8000500D 

Dim sGroupNames 

Dim sGroupDNs 

Dim aGroupNames 

Dim aGroupDNs 

Dim aMemof 

Dim oUser 

Dim tgdn 

Const ForReading = 1, ForWriting = 2, ForAppending = 8

'Настраиваем лог файл

Set fso = CreateObject("Scripting.FileSystemObject")

Set WshShell = WScript.CreateObject("Wscript.Shell")

strSysVarTEMP = WshShell.ExpandEnvironmentStrings("%TEMP%")

Set oScriptLog = fso.OpenTextFile(strSysVarTEMP + "\_dbconn.log",ForWriting,True)

oScriptLog.Write ""

strToLog = CStr(Date())+" "+CStr(Time()) + " - " + "Start..."

oScriptLog.WriteLine(strToLog)

'Проверяем, что 1С установлена

Set objFSO = CreateObject("Scripting.FileSystemObject")

If Not (objFSO.FolderExists("C:\Program Files\1cv82") Or objFSO.FolderExists("C:\Program Files (x86)\1cv82") Or objFSO.FolderExists("C:\Program Files\1cv8") Or objFSO.FolderExists("C:\Program Files (x86)\1cv8")) Then

strToLog = CStr(Date())+" "+CStr(Time()) + " - " + "1C v8 not installed... Quit..."

oScriptLog.WriteLine(strToLog)

    WScript.quit

End If

' 

' Initialise strings. We make the assumption that every account is a member of two system groups 

' 

sGroupNames = "Authenticated Users(S),Everyone(S)" 

' 

' Enter the DN for the user account here 

Set objSysInfo = CreateObject("ADSystemInfo") 

strUserName = objSysInfo.UserName

strToLog = CStr(Date())+" "+CStr(Time()) + " - " + "Logged user DN: "+strUserName

oScriptLog.WriteLine(strToLog)

'  Получаем имя залогиненного пользователя

Set oUser = GetObject("LDAP://" + strUserName) 

If Err.Number <> 0 Then 

        strToLog = CStr(Date())+" "+CStr(Time()) + " - " + "There is an error retrieving the account. Please check your distinguished name syntax assigned to the oUser object." 

        oScriptLog.WriteLine(strToLog)

WScript.quit 

End If 

' 

' Determine the DN of the primary group 

' We make an assumption that every user account is a member of a primary group 

'  

iPgid = oUser.Get("primaryGroupID") 

sGroupDNs = primgroup(iPgid) 

tgdn = sGroupDNs 

' 

' Call a subroutine to extract the group name and scope 

' Add the result to the accumulated group name String 

' 

Call AddGroupName(tgdn) 

Call Getmemof(tgdn) 

' 

' Check the direct group membership for the User account 

' 

aMemOf = oUser.GetEx("memberOf") 

If Err.Number <> PROPERTY_NOT_FOUND Then 

' 

' Call a recursive subroutine to retrieve all indirect group memberships 

' 

        Err.clear 

    For Each GroupDN in aMemof 

        Call AddGroups(GroupDN) 

        Call Getmemof(GroupDN) 

    Next 

End If 

aGroupNames = Split(sGroupNames,",") 

aGroupDNs = Split(sGroupDNs,":") 

'Откидываем все группы, кроме начинающихся с ConnectDB_1C_v8 и ConnectDB_1C_82

For Each strGroupDN in aGroupDNs

if (StrComp(Mid(strGroupDN,1,18), "CN=ConnectDB_1C_82", vbTextCompare) = 0 Or StrComp(Mid(strGroupDN,1,18), "CN=ConnectDB_1C_v8", vbTextCompare) = 0) Then

strToLog = CStr(Date())+" "+CStr(Time()) + " - " + "User is member of: " + strGroupDN

oScriptLog.WriteLine(strToLog)

Set objGroup = GetObject("LDAP://" & strGroupDN)

If Err.Number <> 0 Then 

strToLog = CStr(Date())+" "+CStr(Time()) + " - " + "There is an error retrieving the group. Please check your distinguished name syntax assigned to the objGroup object: " + strGroupDN

oScriptLog.WriteLine(strToLog)

WScript.quit 

End If 

strInfo = objGroup.Get("info")

strToLog = CStr(Date())+" "+CStr(Time()) + " - " + "Group " + strGroupDN +" info field: " + strInfo

oScriptLog.WriteLine(strToLog)

strAllInfo = strAllInfo & ":" & strInfo

End If

Next

aInfoStrings = Split(strAllInfo,":")

Call WriteDBSettings()

Sub WriteDBSettings()

'Прописываем ссылки на v8i файлы в 1CEStart.cfg

strSysVarAPPDATA = WshShell.ExpandEnvironmentStrings("%APPDATA%")

strDBConfigFilePath = strSysVarAPPDATA + "\1C\1CEStart\1CEStart.cfg"

strToLog = CStr(Date())+" "+CStr(Time()) + " - " + "1C Config file is: " + strDBConfigFilePath

oScriptLog.WriteLine(strToLog)

'Проверяем наличие 1CEStart.cfg, если нету - создаем.

If Not (fso.FileExists(strDBConfigFilePath)) Then

strToLog = CStr(Date())+" "+CStr(Time()) + " - " + "1C Config file " + strDBConfigFilePath + " Not Exist!"

oScriptLog.WriteLine(strToLog)

fso.CreateTextFile(strDBConfigFilePath)

strToLog = CStr(Date())+" "+CStr(Time()) + " - " + "1C Config file " + strDBConfigFilePath + " Has been created!"

oScriptLog.WriteLine(strToLog)

End If

Set objDBConfigFile = fso.OpenTextFile(strDBConfigFilePath,ForWriting,True)

objDBConfigFile.Write ""

For each strInfo in aInfoStrings

objDBConfigFile.WriteLine("CommonInfoBases=" + strInfo)

strToLog = CStr(Date())+" "+CStr(Time()) + " - " + "Add Line: " + "CommonInfoBases=" + strInfo

oScriptLog.WriteLine(strToLog)

next

'Изменить UseHWLicenses=1 на 0, если аппаратные лицензии не используются

objDBConfigFile.WriteLine("UseHWLicenses=1")

strToLog = CStr(Date())+" "+CStr(Time()) + " - " + "Add Line: " + "UseHWLicenses=1"

oScriptLog.WriteLine(strToLog)

strToLog = CStr(Date())+" "+CStr(Time()) + " - " + "Ready"

oScriptLog.WriteLine(strToLog)

objDBConfigFile.Close

End Sub

'************************************************************************************************* 

' End of mainline code 

'************************************************************************************************* 

Function primgroup(groupid) 

' This function accepts a primary group id 

' It binds to the local domain and returns the DN of the primary group 

' David Zemdegs 6 May 2008 

' 

Dim oRootDSE,oConn,oCmd,oRset 

Dim ADDomain,srchdmn 

' Bind to loca domain 

Set oRootDSE = GetObject("LDAP://RootDSE") 

ADDomain = oRootDSE.Get("defaultNamingContext") 

srchdmn = "<LDAP://" & ADDomain & ">" 

' 

' Initialise AD search and obtain the recordset of groups 

'  

Set oConn = CreateObject("ADODB.Connection") 

oConn.Open "Provider=ADsDSOObject;" 

Set oCmd = CreateObject("ADODB.Command") 

oCmd.ActiveConnection = oConn 

oCmd.CommandText = srchdmn & ";(objectCategory=Group);" & _ 

        "distinguishedName,primaryGroupToken;subtree"   

Set oRset = oCmd.Execute 

' 

' Loop through the recordset and find the matching primary group token 

' When found retrieve the DN and exit the loop 

'   

Do Until oRset.EOF 

    If oRset.Fields("primaryGroupToken") = groupid Then 

        primgroup = oRset.Fields("distinguishedName") 

        Exit Do 

    End If 

    oRset.MoveNext 

Loop 

' 

' Close and tidy up objects 

'  

oConn.Close 

Set oRootDSE = Nothing 

Set oConn = Nothing 

Set oCmd = Nothing 

Set oRset = Nothing 

End Function 

Sub Getmemof(sDN) 

' 

' This is recursive subroutine that calls itself for memberof Property 

' David Zemdegs 6 May 2008 

' 

On Error Resume Next 

Dim oGrp 

Dim aGrpMemOf 

Dim sGrpDN 

Set oGrp = GetObject("LDAP://" & sDN) 

aGrpMemOf = oGrp.GetEx("memberOf") 

If Err.Number <> PROPERTY_NOT_FOUND Then 

' 

' Call a recursive subroutine to retrieve all indirect group memberships 

' 

        Err.clear 

    For Each sGrpDN in aGrpMemOf 

                Call AddGroups(sGrpDN) 

        Call Getmemof(sGrpDN) 

    Next 

End If 

Err.clear 

Set oGrp = Nothing 

End Sub 

Sub AddGroups(sGdn) 

' 

' This subroutine accepts a disguished name 

' It extracts the RDN as the group name and determines the group scope 

' This is then appended to the group name String 

' It also appends the DN to the DN String 

' 

Const SCOPE_GLOBAL = &h2 

Const SCOPE_LOCAL = &h4 

Const SCOPE_UNIVERSAL = &h8 

Dim SNewgrp 

' 

' Retrieve the group name 

' 

iComma = InStr(1,sGdn,",") 

sGrpName = Mid(sGdn,4,iComma-4) 

' 

' Add the results to the group name String 

' Check that the group doesnt already exist in the list 

' 

sNewgrp = sGrpName 

If InStr(1,sGroupNames,SNewgrp,1) = 0 Then 

        sGroupNames = sGroupNames & "," & SNewgrp 

End If 

' 

' Add the Groups DN to the string if not duplicate 

' 

If InStr(1,sGroupDNs,sGdn,1) = 0 Then 

        sGroupDNs = sGroupDNs & ":" & sGdn 

End If 

End Sub