Пользователь
0,0
рейтинг
25 июля 2014 в 18:38

Администрирование → Управление списком баз 1С 8.2 с помощью Active Directory из песочницы

Приветствую тебя, уважаемый читатель!
По традиции, прошу слишком сильно не пинать, т.к. это мой первый пост.

Итак, приблизительно с полгода назад, встала задача автоматизировать управление списком баз 1С (коих развелось уже более 20 штук) у пользователей домена.
Делалось это не только удобства ради, но и в рамках проекта по внедрению «ролевой модели доступа». Вкратце, смысл этой модели в том, что каждый пользователь в домене является членом определенной группы (именуемой согласно должности), которая имеет заранее определенный набор привилегий, в том числе и список информационных баз.

Т.к. у нас имеется домен Active Directory, логично использовать групповые политики для выполнения нашей задачи.
Гугление выдавало достаточно много реализаций (и даже платных), но все они, чаще всего, сводились к заранее сформированным файлам со списками баз (ibases.v8i). Нам же хотелось:
a) Централизованно управлять настройками подключения к информационным базам (у нас клиент-серверный вариант с SQL базами).
б) Централизованно управлять списком, доступных пользователю, информационных баз, согласно его «роли».

В итоге я расскажу о решении которое работает уже больше полугода в нашей компании.


Итак, приступим.

Шаг 1.

1С 8.2 хранит список информационных баз в файле ibases.v8i, такой файл присутствует в профиле у каждого пользователя. Формат и принцип работы этого файла отлично описаны тут и тут, поэтому я не вижу смысла здесь это повторять.
Также, в одном каталоге с файлом ibases.v8i, находится файл 1CEStart.cfg, особенностью этого файла является то, что в нем можно прописать пути к отдельным файлам *.v8i, содержащим параметры подключения к конкретным информационным базам.
При запуске, 1С берет параметры подключений к информационным базам из файлов, прописанных в 1CEStart.cfg и помещает их в ibases.v8i. Эту-то особенность мы и будем использовать.
Сначала, сформируем файл v8i для каждой информационной базы.
Самый простой способ сформировать такой файлик — это кликнуть правой кнопкой на нужной базе в списке, и выбрать пункт «Сохранить ссылку в файл»:
image
Однако, следует иметь ввиду, что сформированный таким образом файл v8i содержит некоторые «лишние» строки, которые нам не нужны. Для нормальной работы достаточно оставить только следующее:

[%NAME% ]
Connect=Srvr="%server%";Ref="%base%";
ClientConnectionSpeed=Normal
App=Auto
WA=1
Version=8.2

Далее, необходимо разместить эти файлы в общедоступном, для пользователей локальной сети, месте, и дать права на «чтение». Я не стал заморачиваться, и просто разместил их в папке NETLOGON контроллера домена. Тому есть несколько причин — это и репликация каталога между контроллерами домена, и отказоустойчивость (в силу того, что контроллеров три, и в каждый момент времени хотя-бы один из них доступен).

Шаг 2.

Раз мы собираемся управлять списком информационных баз на основе принадлежности пользователя к той или иной группе AD, создадим в ней необходимое количество групп безопасности согласно имеющимся у нас базам 1С:
image

Префикс «1C_82» является обязательным, и далее будет понятно для чего.

Теперь, в каждой вновь созданной группе безопасности, в поле «заметки», укажем путь к соответствующему ей файлу v8i:
image

На этом с группами закончили.

Шаг 3.

Создаем групповую политику, которая будет запускать следующий vbs скрипт каждый раз при логоне пользователя:

Код на vbs
On Error Resume Next
Const PROPERTY_NOT_FOUND  = &h8000500D
Dim sGroupNames
Dim sGroupDNs
Dim aGroupNames
Dim aGroupDNs
Dim aMemof
Dim oUser
Dim tgdn
Dim fso
Dim V8iConfigFile
Dim dir
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")) Then
 strToLog = CStr(Date())+" "+CStr(Time()) + " - " + "1C 8.2 not installed... Quit..."
 oScriptLog.WriteLine(strToLog)
    WScript.quit
End If

'Проверяем есть ли старый файл и удаляем в случае наличия'
 APPDATA = WshShell.ExpandEnvironmentStrings("%APPDATA%")
 v8i = APPDATA + "\1C\1CEStart\ibases.v8i"
 If fso.FileExists(v8i) Then 
	fso.DeleteFile(v8i)
	Set V8iConfigFile = fso.CreateTextFile(v8i ,True)
	strToLog = CStr(Date())+" "+CStr(Time()) + " - " + "Удален файл v8i и создан новый"
	oScriptLog.WriteLine(strToLog)
' Если файла нет (1С только установлена), то создаем файла по указанному пути
 Else
	Set dir = fso.CreateFolder(APPDATA + "\1C")
	Set dir = fso.CreateFolder(dir + "\1CEStart")
	Set V8iConfigFile = fso.CreateTextFile(v8i ,True)
	strToLog = CStr(Date())+" "+CStr(Time()) + " - " + "Создан файл v8i"
	oScriptLog.WriteLine(strToLog)
 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 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,":")

'Откидываем все группы, кроме начинающихся с 1C_82
For Each strGroupDN in aGroupDNs
 if StrComp(Mid(strGroupDN,1,8), "CN=1C_82", 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)

If (fso.FileExists(strDBConfigFilePath)) Then
 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
'Изменить на 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
Else
 Set fso = CreateObject("Scripting.FileSystemObject")
 Set WshShell = WScript.CreateObject("Wscript.Shell")
 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
 strToLog = CStr(Date())+" "+CStr(Time()) + " - " + "1C Config file" + strDBConfigFilePath + " Not Exist! Create!"
 oScriptLog.WriteLine(strToLog)
 WScript.Quit
End If

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



Логика работы скрипта следующая:
1. Проверяет установлена ли 1С, если нет — скрипт завершается.
2. Проверяет существует ли файл ibases.v8i, и перезаписывает его пустым (или создает в случае отсутствия).
3. Извлекает все группы из AD, членом которых является пользователь.
4. Отбрасывает все, кроме тех, которые начинаются с 1C_82.
5. Получает значение атрибута «Notes».
6. Прописывает значение этого атрибута в файл 1CEStart.cfg
Попутно пишется лог:
Для Windows 7 — C:\Users\username\appdata\Local\Temp\_dbconn.log
Для Windows XP — C:\Documents and Settings\username\Local Settings\Temp\_dbconn.log

Шаг 4.

«Вешаем» групповую политику на необходимую OU или весь домен. Стоит отметить, для того, чтоб скрипт не применялся всем подряд без разбора (не все пользователи работают с 1С), я добавил в фильтр безопасности групповой политики только те группы, которые мы создавали на шаге 2, таким образом скрипт будет отрабатывать только у пользователей включенных в хотя-бы одну из этих групп:
image

Шаг 5.

Включаем группу (читай должность) пользователя в те группы 1С, которые предусмотрены ролевой моделью доступа (хотя можно и отдельно взятого пользователя — бывают исключения). После перезагрузки у пользователя будет индивидуальный именно его должности список информационных баз.
Ну вот вроде-бы и все.
Кстати, для применения изменений, пользователю не обязательно перелогиниваться, нужно просто заставить пользователя выполнить этот скрипт любым удобным способом, к примеру, отправив скрипт по электронной почте.

Спасибо за внимание, буду очень рад, если статья кому-то поможет.
Павел @4mz
карма
8,0
рейтинг 0,0
Реклама помогает поддерживать и развивать наши сервисы

Подробнее
Реклама

Самое читаемое Администрирование

Комментарии (17)

  • 0
    Сколько же головной боли снимет этот скрипт.

    Остается только 1 вопрос. Часто пользователю требуется иметь локальную базу. А дынный скрипт будет каждый раз удалять ее.
    Не сталкивались с решениями которые могли бы обнаруживать еще и локальные базы?
    • 0
      Для локальной базы, можно просто иметь на рабочем столе файл *.v8i с прописанными параметрами подключения (такой-же как формировали на шаге 2), кликнув на него, у вас откроется именно эта база :)
      • 0
        Спасибо за идею, этому обучить необходимых людей не сложно.
        • 0
          Вы знаете, я вас дезинформировал, прошу прощения. Сам только что проверил — не получается, хотя раньше работало — я точно уверен. Попробую найти решение и обязательно отпишусь!
          • 0
            Что странно у меня тоже ведь такой способ работал. В понедельник проверю отпишусь.

            Скоро подобное для 8.3 осваивать нужно будет. Интересно там много поменяли…
            • 0
              Хотелось бы надеяться на обратную совместимость, ибо «наши» уже вовсю 8.3 тестят…
  • 0
    Лет 6 назад писал vbs скрипт который который умел добавлять, удалять и исправлять базы у пользователя. С тех пор ничего не изменилось. Даже и не думал что это такая проблема. Поищу в архивах, может сохранился.
    • 0
      Пожалуйста, если не трудно, то выложите ваши наработки.
  • 0
    Просто отлично, в избранное :)

    Вопрос почти по теме: сейчас воюю с 1С сервером под Debian'ом, пытаюсь его научить авторизовать пользователей по учётным записям в AD. Пока получается не очень :( если есть у кого-нибудь в закромах годный гайд, был бы очень признателен.
  • 0
    Эммм, зачем столько всего? Наверняка есть уже определенные наборы баз, нужные определенным категориям пользователей. Создайте на шаре папки с именами этих наборов (для бухгалтерии, руководства, финотдела и проч.). В каждую папку положите ibases, 1cestart и 1cescmn. В 1cestart пропишите сетевой путь до лежащего рядом 1cescmn.cfg (commoncfglocation). В 1cescmn.cfg пропишите ссылку на лежащий в этой же папке список баз. Теперь раздайте 1cestart.cfg из нужной папки нужным пользователям по GP в %appdata%\1с.

    Таким образом, при старте 1с полезет на шару в нужную папку за списком баз. Вы можете оперативно менять список баз на шаре, при этом он будет меняться и у пользователей. Базы, добавленные пользователем вручную на этот список не влияют.
  • 0
    При таком подходе при каждом входе у юзера будет создаваться новый кэш конфигурации, что замедлит старт системы, но с другой стороны застрахует от ошибок этого самого кэша. Кроме того, старый кэш у вас не уничтожается и копится в виде мусора.
  • 0
    Писалось для 1С 8.1 8.2, на основании этого добра, со скуки был написан генератор этого скрипта на delphi (если нужно, попробую почистить его и выложить)
    Функции:
    Добавление, исправление, записей к базам.
    Создание файла с записями, если не существовал.
    Установка новых релизов платформ (требует ввода пароля во всплывающем окне командной строки для пользователя Setup@DOMAIN.LOCAL). Криво, но на тот момент вариантов увы не было.
    Фильтрация добавления, исправления, записей к базам для конкретных групп.
    Установка компоненты ScanOPOS для 1С
    и может быть что то еще ))

    Код
    on error resume next
    
    Dim FSO,WshShell,WshEnvVolatile,WshEnvUser,UserProfile
    Dim Title81(),Server81(),Base81(),ConnType81(),Incor81(),Add81()
    Dim Title82(),Server82(),Base82(),ConnType82(),Incor82(),Add82()
    Dim arrMyFile81,arrMyFile82
    
    Set WshShell = CreateObject("WScript.Shell")
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set WshEnvVolatile = WshShell.Environment("Volatile")
    Set WshEnvUser = WshShell.Environment("User")
    Set WshEnvPROCESS = WshShell.Environment("PROCESS")
    Set WshNet=WScript.CreateObject("WScript.Network")
    Set objGroup1 = GetObject("LDAP://CN="+WshNet.UserName+",CN=Users,DC=DOMAIN,DC=LOCAL")
    GroupList=objGroup1.GetEx("memberOf")
    '#################Настройки#####################
    SkipChekBase81 = 1 ' Если 1, то не исправлять пути к базам 8.1
    SkipChekBase82 = 1 ' Если 1, то не исправлять пути к базам 8.2
    SkipAddBase81 = 1 ' Если 1, не добавлять новые базы 8.1
    SkipAddBase82 = 0 ' Если 1, не добавлять новые базы 8.2
    SkipEraseCache82 = 1  ' Если 1, не очищать кэш 8.2
    SkipEndEcho = 1 ' Если 1, не показывать сообщение по окончанию работы скрипта
    
    SkipSetup = 1  ' Если 1, не производить установку
    strRELIZ = "C:\Program Files\1cv82\8.2.13.205\"
    strRunRELIZ = "\\DOMAIN.LOCAL\SYSVOL\DOMAIN.LOCAL\1C_82\setup.exe"
    strRunAs = "runas /user:Setup@DOMAIN.LOCAL"
    ScanOposdll = "\\DOMAIN.LOCAL\SYSVOL\DOMAIN.LOCAL\1C_82\ScanOPOS.dll\"
    SkipScanOpos = 1  ' Если 1, не производить установку ScanOpos.dll в папку strRELIZ\bin\
    
    'Не выполнять для пользователей входящих в группу
    SkipGroup = "GroupProg1C"
    SkipGroupChekBase81 = 1 ' Если 1, то не исправлять пути к базам 8.1
    SkipGroupChekBase82 = 1 ' Если 1, то не исправлять пути к базам 8.2
    SkipGroupAddBase81 = 1 ' Если 1, не добавлять новые базы 8.1
    SkipGroupAddBase82 = 1 ' Если 1, не добавлять новые базы 8.2
    
    
    '###############################################
    
    Numb81 = -1 'не менять
    Numb82 = -1 'не менять
    
    '##### 8.1 Bases #####
    'ZP_GR
    Numb81=Numb81+1 'не менять
    Redim Preserve Title81(Numb81),Server81(Numb81),Base81(Numb81),ConnType81(Numb81),Incor81(Numb81),Add81(Numb81) 'не менять
    Title81(Numb81) = "[ZP_GR]"
    ConnType81(Numb81) = "Srvr"
    Server81(Numb81) = "bdsrv"
    Base81(Numb81) = "ZP_GR"
    Incor81(Numb81) = 0 'не менять
    Add81(Numb81) =  0 'Если 1, то прописать базу
    
    'Торговое оборудование
    Numb81=Numb81+1
    Redim Preserve Title81(Numb81),Server81(Numb81),Base81(Numb81),ConnType81(Numb81),Incor81(Numb81),Add81(Numb81)
    Title81(Numb81) = "[Торговое оборудование]"
    ConnType81(Numb81) = "Srvr"
    Server81(Numb81) = "bdsrv"
    Base81(Numb81) = "TorgovoeOborudovanie"
    Incor81(Numb81) = 0 'не менять
    Add81(Numb81) =  0 'Если 1, то прописать базу
    
    
    '#####################
    'Мусор, но без него удаляются записи 8.1
    ID = "ID=00000000-0000-0000-0000-00000000001"
    OrderInList = "OrderInList=0"
    Folder = "Folder=/"
    OrderInTree = "OrderInTree=0"
    External = "External=0"
    '#####################
    
    '##### 8.2 Bases #####
    
    'Сайт_через_сайт
    Numb82=Numb82+1
    Redim Preserve Title82(Numb82),Server82(Numb82),Base82(Numb82),ConnType82(Numb82),Incor82(Numb82),Add82(Numb82)
    Title82(Numb82) = "[Сайт]"
    ConnType82(Numb82) = "ws"
    Server82(Numb82) = "http://SRV.RU:8081/"
    Base82(Numb82) = "dsite/"
    Incor82(Numb82) = 0 'не менять
    Add82(Numb82) =  0 'Если 1, то прописать базу
    
    'Сайт_Резерв
    Numb82=Numb82+1
    Redim Preserve Title82(Numb82),Server82(Numb82),Base82(Numb82),ConnType82(Numb82),Incor82(Numb82),Add82(Numb82)
    Title82(Numb82) = "[Сайт_Резерв]"
    ConnType82(Numb82) = "Srvr"
    Server82(Numb82) = "SRV"
    Base82(Numb82) = "dsite"
    Incor82(Numb82) = 0 'не менять
    Add82(Numb82) = 1 'Если 1, то прописать базу
    
    If SkipSetup = 0 Then
      If NOT FSO.FileExists(strRELIZ & "bin\1cv8.exe") Then
    	Set oExec = WshShell.Run(strRunAs & " " & Chr(34) & strRunRELIZ & " /S" & Chr(34),1,true)
      'Else 
        'WScript.Echo "Релиз 8.2.13.205 уже установлен. Нажмите " &Chr(34)& "Ок" &Chr(34)& " для продолжения"
      End If
    End If  
    If SkipScanOpos = 0 Then
    	If NOT FSO.FileExists(strRELIZ & "bin\ScanOPOS.dll") Then
    	  TimeStart = 0
    	  Do 
    	    If FSO.FolderExists(strRELIZ & "bin") Then Exit Do End If
    	    TimeStart = TimeStart + 1
            WScript.sleep 30000
    	  Loop Until TimeStart = 10
          Set oExec1 = WshShell.Run(strRunAs & Chr(32) & Chr(34) & "cmd " & Chr(47)& "C copy " & Chr(92) & Chr(34) & ScanOposdll & Chr(34) & Chr(32) & Chr(92) & Chr(34)& strRELIZ & "\bin\" & Chr(92) & Chr(34) & Chr(34),1,true)  
    	End If
    End If
    
    
    AppData = WshEnvVolatile.Item("APPDATA")
    UserName = WshEnvUser.Item("USERNAME")
    Path1C = AppData & "\1C"
    
    
    Path1C81 = AppData & "\1C\1Cv81" 'Путь к папке с файлом базы
    File1C81 = Path1C81 & "\ibases.v8i"
    File1C81New = Path1C81 & "\ibases.new"
    
    Path1C82 = AppData & "\1C\1CEStart" 'Путь к папке с файлом базы
    File1C82 = Path1C82 & "\ibases.v8i"
    File1C82New = Path1C82 & "\ibases.new"
    
    for Each val in GroupList 
      str = lcase(val)
      str1 = lcase("CN="&SkipGroup&",CN=Users,DC=DOMAIN,DC=LOCAL")
      If str=str1 Then
        If SkipGroupChekBase81 = 1 Then SkipChekBase81 = 1 End If
        If SkipGroupChekBase82 = 1 Then SkipChekBase82 = 1 End If
        If SkipGroupAddBase81 = 1 Then SkipAddBase81  = 1 End If
        If SkipGroupAddBase82 = 1 Then SkipAddBase82  = 1 End If
      End if
    next
    
    '#########################################
    If FSO.FolderExists(Path1C) Then  'Проверка существования пути AppData & "\1C", если нет, создаем
    Else
      FSO.CreateFolder(AppData & "\1C") 'Создаем папку "\1C"
    End If
    
    If FSO.FolderExists(Path1C81) Then  'Проверка существования пути, если нет, создаем
      If FSO.FileExists(File1C81) Then 'Проверка существования файла баз, если нет, создаем
        Set File81 = FSO.OpenTextFile(File1C81, 1) 'Читаем файл с базами
        Set Temp81 = FSO.CreateTextFile(File1C81New, true) 'Создаем temp фаил
      Else
        Set File81 = FSO.CreateTextFiles(File1C81, true) 'Создаем File фаил
        Set Temp81 = FSO.CreateTextFile(File1C81New, true) 'Создаем temp фаил  
      End If
    Else
      FSO.CreateFolder(AppData & "\1C\1Cv81")
      Set File81 = FSO.CreateTextFiles(File1C81, true) 'Читаем файл с базами
      Set Temp81 = FSO.CreateTextFile(File1C81New, true) 'Создаем temp фаил
    End If
    
    If FSO.FolderExists(Path1C82) Then  'Проверка существования пути, если нет, создаем
      If FSO.FileExists(File1C82) Then 'Проверка существования файла баз, если нет, создаем
        Set File82 = FSO.OpenTextFile(File1C82, 1) 'Читаем файл с базами
        Set Temp82 = FSO.CreateTextFile(File1C82New, true) 'Создаем temp фаил
      Else
        Set File82 = FSO.CreateTextFiles(File1C82, true) 'Создаем File фаил
        Set Temp82 = FSO.CreateTextFile(File1C82New, true) 'Создаем temp фаил  
      End If
    Else
      FSO.CreateFolder(AppData & "\1C\1CEStart")
      Set File82 = FSO.CreateTextFiles(File1C82, true) 'Читаем файл с базами
      Set Temp82 = FSO.CreateTextFile(File1C82New, true) 'Создаем temp фаил
    End If
    '#########################################
    
    
      arrMyFile81 = Split(File81.ReadAll, vbNewLine) 'Создаем массив из файла с базами 81
      For a = 0 To UBound(arrMyFile81) 'Читаем поэлементно массив arrMyFile81
       str81 = arrMyFile81(a) 'строка из массива
       str81Low = lcase(arrMyFile81(a)) 'строка из массива переведенная в нижний регистр
       If InStr(1, str81Low, "connect", vbTextCompare) Then 'Находим строку с путями к базе
         Result = 0 'Флаг нахождения строки конекта, если база не указанна в списке, то строка будет записанна без изменений
         For b = 0 To UBound(Base81) 'Обрабатываем массив предопределенных баз
           If InStr(1, str81Low, lcase(Base81(b)), vbTextCompare) Then 'Ищем базу Base81(b)
             If InStr(1, str81Low, lcase(ConnType81(b)), vbTextCompare) Then 'Проверяем тип соединения
               Result = 1 'Флаг База найдена
               Add81(b) = 0 'Флаг База уже прописанна
             End If
             If SkipChekBase81 = 0 Then
               If InStr(1, str81Low, lcase(Server81(b)), vbTextCompare) Then 'Проверяем адресс сервера прописанный для базы Base81(b), и если он правельный по заканчиваем обработку строки, если неправильный, правим
                 Result = 0 'Пишем строку без изменений
               Else
                 If ConnType81(b) = "File" Then Temp81.WriteLine("Connect="&ConnType81(b)&"="&Chr(34)&Base81(b)&Chr(34)&";") End If 
                 If ConnType81(b) = "Srvr" Then Temp81.WriteLine("Connect="&ConnType81(b)&"="&Chr(34)&Server81(b)&Chr(34)&";Ref="&Chr(34)&Base81(b)&Chr(34)&";") End If
               End If
             Else
               Result = 0
             End If
           End If
         Next
         If Result = 0 Then Temp81.WriteLine(str81) End If 
       Else
         Temp81.WriteLine(str81) 'Пишем строку без изменений если не найдено слово connect
       End If
      Next
    
      arrMyFile82 = Split(File82.ReadAll, vbNewLine) 'Создаем массив из файла с базами 82
      For a = 0 To UBound(arrMyFile82) 'Читаем поэлементно массив arrMyFile82
       str82 = arrMyFile82(a) 'строка из массива
       str82Low = lcase(arrMyFile82(a)) 'строка из массива переведенная в нижний регистр
       If InStr(1, str82Low, "connect", vbTextCompare) Then 'Находим строку с путями к базе
         Result = 0
         For b = 0 To UBound(Base82) 'Обрабатываем массив предопределенных баз
           If InStr(1, str82Low, lcase(Base82(b)), vbTextCompare) Then 'Ищем базу Base82(b)
    	     If InStr(1, str82Low, lcase(ConnType82(b)), vbTextCompare) Then 'Проверяем тип соединения
               Result = 1
               Add82(b) = 0 ' База существует
             End If
             If SkipChekBase82 = 0 Then
               If InStr(1, str82Low, lcase(Server82(b)), vbTextCompare) Then 'Проверяем адресс сервера прописанный для базы Base82(b), и если он правельный по заканчиваем обработку строки, если неправильный, правим
                 Result = 0 'Пишем строку без изменений
               Else
                 If ConnType82(b) = "ws" Then Temp82.WriteLine("Connect="&ConnType82(b)&"="&Chr(34)&Server82(b)&Base82(b)&Chr(34)&";") End If 
                 If ConnType82(b) = "Srvr" Then Temp82.WriteLine("Connect="&ConnType82(b)&"="&Chr(34)&Server82(b)&Chr(34)&";Ref="&Chr(34)&Base82(b)&Chr(34)&";") End If
               End If
             Else
               Result = 0
             End If
           End If
         Next
    	 If Result = 0 Then Temp82.WriteLine(str82) End If
       Else
         Temp82.WriteLine(str82) 'Пишем строку без изменений если не найдено слово connect
       End If
      Next
    
    If SkipAddBase81 = 0 Then
        For a = 0 To UBound(Add81) 'Добавляем базы у которых Add(a) = 1
           If Add81(a) = 1 Then
             Temp81.WriteLine(Title81(a))
             If ConnType81(a) = "File" Then Temp81.WriteLine("Connect="&ConnType81(a)&"="&Chr(34)&Base81(a)&Chr(34)&";") End If 
             If ConnType81(a) = "Srvr" Then Temp81.WriteLine("Connect="&ConnType81(a)&"="&Chr(34)&Server81(a)&Chr(34)&";Ref="&Chr(34)&Base81(a)&Chr(34)&";") End If
    		 Temp81.WriteLine(ID&a)
    		 Temp81.WriteLine(OrderInList)
    		 Temp81.WriteLine(Folder)
    		 Temp81.WriteLine(OrderInTree)
    		 Temp81.WriteLine(External)
           End If
        Next
    End If
    
    If SkipAddBase82 = 0 Then
        For a = 0 To UBound(Add82) 'Добавляем базы у которых Add(a) = 1
           If Add82(a) = 1 Then
             Temp82.WriteLine(Title82(a))
             If ConnType82(a) = "ws" Then Temp82.WriteLine("Connect="&ConnType82(a)&"="&Chr(34)&Server82(a)&Base82(a)&Chr(34)&";") End If 
             If ConnType82(a) = "Srvr" Then Temp82.WriteLine("Connect="&ConnType82(a)&"="&Chr(34)&Server82(a)&Chr(34)&";Ref="&Chr(34)&Base82(a)&Chr(34)&";") End If
           End If
        Next
    End If
    
    File81.Close
    Temp81.Close
    FSO.DeleteFile File1C81, 0
    FSO.MoveFile File1C81New, File1C81
    
    File82.Close
    Temp82.Close
    FSO.DeleteFile File1C82, 0
    FSO.MoveFile File1C82New, File1C82
    
    If SkipEraseCache82 = 0 Then 
      UserProfile = WshEnvPROCESS.Item("userprofile")
      FSO.DeleteFolder(UserProfile & "\Application Data\1C\1Cv82")
      FSO.DeleteFolder(UserProfile & "\Local Settings\Application Data\1C\1Cv82")
    End If
    
    
    If SkipEndEcho = 0 Then
      WScript.Echo "Скрипт выполнен. Нажмите " &Chr(34)& "Ок" &Chr(34)& " для выхода"
    End If
    
    


    vbscript — изучал на написании данного скрипта, соответственно может быть очень криво.
    Коментарии писал вроде бы понятные.
    Если есть вопросы по этой каше, спрашивайте, попробую вспомнить почему так писал.
  • –2
    Никогда не думал, что это может потянуть на статью на Хабре, если будет интересно и пригодится то вот код скрипта vbs, который создает ярлыки подключений к терминальным серверам как в режиме удаленного рабочего стола с прописанной средой запуска, так и в режиме запуска опубликованного приложения. Фишка скрипта — определение размера экрана пользователя при запуске и установка именно такого размера экрана в свойствах подключения.
    ' Скрипт создания на рабочем столе пользователя ярлыка удаленного подключения к рабочему столу ' или подключения Remote Apps, базируясь на членстве в группах безопасности. ' ' Шаблон названия группы для создания ярлыка подключения к удаленному рабочему столу ' ================================================================================== ' Префикс названия группы: RDP_ /все после префикса - название ярлыка/ ' Описание группы: имя сервера для подключения ' Заметки группы: среда для запуска при входе на терминальный сервер, например "C:\Program Files (x86)\1cv81\bin\1cv8.exe" enterprise /S APP-SRV\base ' ' Шаблон названия группы для создания ярлыка подключения к Remote Apps ' ================================================================================== ' Префикс названия группы: RemApps_ /все после префикса - название ярлыка/ ' Описание группы: имя сервера для подключения ' Заметки группы: псевдоним опубликованного приложения на сервере терминалов On Error Resume Next Set wshShell = WScript.CreateObject("WScript.Shell") Set m_FSO = CreateObject("Scripting.FileSystemObject") ' определяем размер рабочего стола Set Locator = CreateObject("WbemScripting.SWbemLocator") Set Services = Locator.ConnectServer(".") Set Obj = Services.ExecQuery("Select * from Win32_DesktopMonitor") For Each Item In Obj If Item.Availability=3 Then resy = Item.ScreenWidth resx = Item.ScreenHeight End If Next ' WScript.Echo "По вертикали="& resx ' WScript.Echo "По горизонтали="& resy ' Находим пользователя в AD и определем его параметры Set objSysInfo = CreateObject("ADSystemInfo") ADSPath = "LDAP://" & objSysInfo.UserName Set objUser = GetObject(ADSPath) ShortUserName = objUser.SamAccountName DomainName = objSysInfo.DomainShortName ' Читаем путь к Рабочему столу DesktopPath = wshShell.SpecialFolders("Desktop") LevelCount = 0 MaxLevelCount = 4 Status = CheckGroups(ADSPath) ' дальше идет нудный перечень используемых функций '============ Function GetPrefixNameGroup ============ Function GetPrefixNameGroup(sString) ' Trim prefix of name group Dim TempString TempString = Left(sString, InStr(sString, "_")) GetPrefixNameGroup = TempString End Function '===================================================== '============ Function GetLinkNameGroup ============ Function GetLinkNameGroup(sString) ' Trim LinkName of name group Dim TempString TempString = Mid(sString, InStrRev(sString, "_")+1) GetLinkNameGroup = TempString End Function '===================================================== '============ Function Create Remote Application File ============ Function CreateRemAppsFile(sString, sName, sShell) spath = DesktopPath & "\" & sString & ".rdp" ' проверяем наличие такого же файла - если есть - удаляем его' If m_FSO.FileExists(sPath) or m_FSO.FolderExists(sPath) Then m_FSO.DeleteFile (sPath),1 End If Set RDPFile = m_FSO.CreateTextFile (spath, True) RDPFile.writeline ("redirectclipboard:i:1") RDPFile.writeline ("redirectposdevices:i:0") RDPFile.writeline ("redirectprinters:i:0") RDPFile.writeline ("redirectcomports:i:1") RDPFile.writeline ("redirectsmartcards:i:0") RDPFile.writeline ("drivestoredirect:s:") RDPFile.writeline ("session bpp:i:32") RDPFile.writeline ("prompt for credentials on client:i:1") RDPFile.writeline ("span monitors:i:1") RDPFile.writeline ("use multimon:i:1") RDPFile.writeline ("remoteapplicationmode:i:1") RDPFile.writeline ("server port:i:3389") RDPFile.writeline ("allow font smoothing:i:1") RDPFile.writeline ("promptcredentialonce:i:1") RDPFile.writeline ("authentication level:i:2") RDPFile.writeline ("gatewayusagemethod:i:0") RDPFile.writeline ("gatewayprofileusagemethod:i:1") RDPFile.writeline ("gatewaycredentialssource:i:0") RDPFile.writeline ("full address:s:" & sName) RDPFile.writeline ("remoteapplicationprogram:s:||" & sShell) RDPFile.writeline ("gatewayhostname:s:") RDPFile.writeline ("remoteapplicationname:s:" & sString) RDPFile.writeline ("screen mode id:i:2") RDPFile.writeline ("desktopwidth:i:" & resy) RDPFile.writeline ("desktopheight:i:" & resx) RDPFile.writeline ("winposstr:s:0,3,0,0,800,600") RDPFile.writeline ("compression:i:1") RDPFile.writeline ("keyboardhook:i:2") RDPFile.writeline ("audiocapturemode:i:0") RDPFile.writeline ("videoplaybackmode:i:1") RDPFile.writeline ("connection type:i:2") RDPFile.writeline ("displayconnectionbar:i:1") RDPFile.writeline ("disable wallpaper:i:1") RDPFile.writeline ("allow desktop composition:i:0") RDPFile.writeline ("disable full window drag:i:1") RDPFile.writeline ("disable menu anims:i:1") RDPFile.writeline ("disable themes:i:0") RDPFile.writeline ("disable cursor setting:i:0") RDPFile.writeline ("bitmapcachepersistenable:i:1") RDPFile.writeline ("audiomode:i:0") RDPFile.writeline ("redirectdirectx:i:1") RDPFile.writeline ("autoreconnection enabled:i:1") RDPFile.writeline ("prompt for credentials:i:0") RDPFile.writeline ("negotiate security layer:i:1") RDPFile.writeline ("remoteapplicationicon:s:") RDPFile.writeline ("shell working directory:s:") RDPFile.writeline ("use redirection server name:i:0") RDPFile.close End Function '============ Function Create RdpFile ============ Function CreateRDPFile(sString, sName, sShell) spath = DesktopPath & "\" & sString & ".rdp" ' проверяем наличие такого же файла - если есть - удаляем его' If m_FSO.FileExists(sPath) or m_FSO.FolderExists(sPath) Then m_FSO.DeleteFile (sPath),1 End If Set RDPFile = m_FSO.CreateTextFile (spath, True) RDPFile.writeline ("screen mode id:i:2") RDPFile.writeline ("use multimon:i:0") RDPFile.writeline ("desktopwidth:i:" & resy) RDPFile.writeline ("desktopheight:i:" & resx) RDPFile.writeline ("session bpp:i:16") RDPFile.writeline ("winposstr:s:0,3,0,0,800,600") RDPFile.writeline ("compression:i:1") RDPFile.writeline ("keyboardhook:i:2") RDPFile.writeline ("audiocapturemode:i:0") RDPFile.writeline ("videoplaybackmode:i:1") RDPFile.writeline ("connection type:i:2") RDPFile.writeline ("displayconnectionbar:i:1") RDPFile.writeline ("disable wallpaper:i:1") RDPFile.writeline ("disable full window drag:i:1") RDPFile.writeline ("allow desktop composition:i:0") RDPFile.writeline ("allow font smoothing:i:0") RDPFile.writeline ("disable menu anims:i:1") RDPFile.writeline ("disable themes:i:1") RDPFile.writeline ("disable cursor setting:i:0") RDPFile.writeline ("bitmapcachepersistenable:i:1") RDPFile.writeline ("full address:s:" & sName) RDPFile.writeline ("audiomode:i:2") RDPFile.writeline ("redirectprinters:i:0") RDPFile.writeline ("redirectcomports:i:0") RDPFile.writeline ("redirectsmartcards:i:0") RDPFile.writeline ("redirectclipboard:i:1") RDPFile.writeline ("redirectposdevices:i:0") RDPFile.writeline ("redirectdirectx:i:1") RDPFile.writeline ("autoreconnection enabled:i:1") RDPFile.writeline ("authentication level:i:0") RDPFile.writeline ("prompt for credentials:i:0") RDPFile.writeline ("negotiate security layer:i:1") RDPFile.writeline ("remoteapplicationmode:i:0") RDPFile.writeline ("alternate shell:s:" & sShell) RDPFile.writeline ("shell working directory:s:") RDPFile.writeline ("gatewayhostname:s:") RDPFile.writeline ("gatewayusagemethod:i:4") RDPFile.writeline ("gatewaycredentialssource:i:4") RDPFile.writeline ("gatewayprofileusagemethod:i:0") RDPFile.writeline ("promptcredentialonce:i:1") RDPFile.writeline ("drivestoredirect:s:*") RDPFile.writeline ("use redirection server name:i:0") RDPFile.close End Function '===================================================== '============ Function CheckGroups =================== Function CheckGroups(ADSPath) Dim objUser, arrMemberOf Const E_ADS_PROPERTY_NOT_FOUND = &h8000500D LevelCount = LevelCount + 1 if ( LevelCount >= MaxLevelCount) then LevelCount = LevelCount - 1 return LevelCount end If Set objUser = GetObject (ADSPath) On Error Resume Next arrMemberOf = objUser.GetEx("memberOf") If Err.Number = E_ADS_PROPERTY_NOT_FOUND Then LevelCount = LevelCount - 1 return LevelCount Else For Each Group in arrMemberOf ADSGroup = "LDAP://" & Group CheckGroups(ADSGroup) ' WScript.Echo "Extra=" & LevelCount Set objGroup = GetObject ( ADSGroup ) If(GetPrefixNameGroup(objGroup.CN) = "RemApps_") Then Set objGroup = GetObject ( "LDAP://" & Group) LinkName = GetLinkNameGroup(objGroup.CN) LinkServer = objGroup.description LinkProgram = objGroup.info LinkResult = CreateRemAppsFile (LinkName, LinkServer, LinkProgram) end If If(GetPrefixNameGroup(objGroup.CN) = "RDP_") Then Set objGroup = GetObject ( "LDAP://" & Group) LinkName = GetLinkNameGroup(objGroup.CN) LinkServer = objGroup.description LinkProgram = objGroup.info LinkResult = CreateRDPFile (LinkName, LinkServer, LinkProgram) end If Next End If LevelCount = LevelCount - 1 End Function

    Следующий код делает почти тоже самое что и скрипт автора топика, но я не проверяю установлена ли 1С и формирую файлы с списками баз в профиле пользователя каждый раз при входе, предварительно их удаляя. В описании группы название базы в списке баз и в заметках параметры подключения к базе. Скрипт не мой, просил сделать на фрилансе, поэтому если кто то узнает свой код — еще раз примите благодарности, несколько лет не знаю горя.

    ' Префикс названий групп prefix_1c = "1c_" ' Получаем имя пользователя set info = CreateObject( "ADSystemInfo" ) ' Получаем учетную запись set user = GetObject( "LDAP://" & info.UserName ) ' Создаем файловые потоки set res_81 = CreateObject( "ADODB.Stream" ) res_81.Type = 2 res_81.Charset = "UTF-8" res_81.Open res_81.Position = 0 set res_82 = CreateObject( "ADODB.Stream" ) res_82.Type = 2 res_82.Charset = "UTF-8" res_82.Open res_82.Position = 0 memberOf = user.memberOf ' Просматривает список групп If (not (IsEmpty(memberOf)) ) then For Each item in user.memberOf set group = GetObject( "LDAP://" & item ) if (InStr( group.CN, prefix_1c ) = 1) then if (InStr( group.info, "Version=8.1" ) > 0) then res_81.WriteText( "[" & group.Description & "]" & Chr(13) & Chr(10) ) res_81.WriteText( group.info & Chr(13) & Chr(10) ) end if if (InStr( group.info, "Version=8.2" ) > 0) then res_82.WriteText( "[" & group.Description & "]" & Chr(13) & Chr(10) ) res_82.WriteText( group.info & Chr(13) & Chr(10) ) end if end if next end if ' Ищем путь до файлов set shell = CreateObject( "WScript.Shell" ) appdata = shell.ExpandEnvironmentStrings( "%APPDATA%" ) ' Создать папки set fso = CreateObject( "Scripting.FileSystemObject" ) if (not fso.FolderExists( appdata + "\1C" )) then fso.CreateFolder( appdata + "\1C" ) end if if (not fso.FolderExists( appdata + "\1C\1Cv81" )) then fso.CreateFolder( appdata + "\1C\1Cv81" ) end if if (not fso.FolderExists( appdata + "\1C\1CEStart" )) then fso.CreateFolder( appdata + "\1C\1CEStart" ) end if ' И пишем файлы туда res_81.SaveToFile appdata & "\1C\1Cv81\ibases.v8i", 2 res_81.Close res_82.SaveToFile appdata & "\1C\1CEStart\ibases.v8i", 2 res_82.Close
  • 0
    Это нереальная лажа, я не проверил свой комментарий и ошибся с тегами. Прошу пардону.

    Никогда не думал, что это может потянуть на статью на Хабре, если будет интересно и пригодится то вот код скрипта vbs, который создает ярлыки подключений к терминальным серверам как в режиме удаленного рабочего стола с прописанной средой запуска, так и в режиме запуска опубликованного приложения. Фишка скрипта — определение размера экрана пользователя при запуске и установка именно такого размера экрана в свойствах подключения.

    Код
    ' Скрипт создания на рабочем столе пользователя ярлыка удаленного подключения к рабочему столу 
    ' или подключения Remote Apps, базируясь на членстве в группах безопасности.
    ' 
    ' Шаблон названия группы для создания ярлыка подключения к удаленному рабочему столу
    ' ==================================================================================
    ' Префикс названия группы: RDP_ /все после префикса - название ярлыка/
    ' Описание группы: имя сервера для подключения
    ' Заметки группы: среда для запуска при входе на терминальный сервер, например "C:\Program Files (x86)\1cv81\bin\1cv8.exe" enterprise /S APP-SRV\base
    ' 
    ' Шаблон названия группы для создания ярлыка подключения к Remote Apps
    ' ==================================================================================
    ' Префикс названия группы: RemApps_ /все после префикса - название ярлыка/
    ' Описание группы: имя сервера для подключения
    ' Заметки группы: псевдоним опубликованного приложения на сервере терминалов
    
    On Error Resume Next
    Set wshShell = WScript.CreateObject("WScript.Shell")
    Set m_FSO = CreateObject("Scripting.FileSystemObject")
    
    ' определяем размер рабочего стола
    
    Set Locator = CreateObject("WbemScripting.SWbemLocator")
    Set Services = Locator.ConnectServer(".")
    Set Obj = Services.ExecQuery("Select * from Win32_DesktopMonitor")
    
    For Each Item In Obj
    If Item.Availability=3 Then
    resy = Item.ScreenWidth
    resx = Item.ScreenHeight
    End If
    
    Next
    
    ' WScript.Echo "По вертикали="& resx
    ' WScript.Echo "По горизонтали="& resy
    
    ' Находим пользователя в AD и определем его параметры
    
    Set objSysInfo = CreateObject("ADSystemInfo")
    ADSPath = "LDAP://" & objSysInfo.UserName
    Set objUser = GetObject(ADSPath)
    ShortUserName = objUser.SamAccountName
    DomainName = objSysInfo.DomainShortName
    
    ' Читаем путь к Рабочему столу
    
    DesktopPath = wshShell.SpecialFolders("Desktop")
    LevelCount = 0
    MaxLevelCount = 4
    Status = CheckGroups(ADSPath)
    
    ' дальше идет нудный перечень используемых функций
    '============ Function GetPrefixNameGroup ============
    
    Function GetPrefixNameGroup(sString)
    ' Trim prefix of name group
    Dim TempString
    TempString = Left(sString, InStr(sString, "_"))
    GetPrefixNameGroup = TempString
    End Function
    
    '=====================================================
    '============ Function GetLinkNameGroup ============
    
    Function GetLinkNameGroup(sString)
    ' Trim LinkName of name group
    Dim TempString
    TempString = Mid(sString, InStrRev(sString, "_")+1)
    GetLinkNameGroup = TempString
    End Function
    
    '=====================================================
    '============ Function Create Remote Application File ============
    
    Function CreateRemAppsFile(sString, sName, sShell)
    spath = DesktopPath & "\" & sString & ".rdp"
    
    ' проверяем наличие такого же файла - если есть - удаляем его'
    
    If m_FSO.FileExists(sPath) or m_FSO.FolderExists(sPath) Then
    m_FSO.DeleteFile (sPath),1
    End If
    
    Set RDPFile = m_FSO.CreateTextFile (spath, True)
    RDPFile.writeline ("redirectclipboard:i:1")
    RDPFile.writeline ("redirectposdevices:i:0")
    RDPFile.writeline ("redirectprinters:i:0")
    RDPFile.writeline ("redirectcomports:i:1")
    RDPFile.writeline ("redirectsmartcards:i:0")
    RDPFile.writeline ("drivestoredirect:s:")
    RDPFile.writeline ("session bpp:i:32")
    RDPFile.writeline ("prompt for credentials on client:i:1")
    RDPFile.writeline ("span monitors:i:1")
    RDPFile.writeline ("use multimon:i:1")
    RDPFile.writeline ("remoteapplicationmode:i:1")
    RDPFile.writeline ("server port:i:3389")
    RDPFile.writeline ("allow font smoothing:i:1")
    RDPFile.writeline ("promptcredentialonce:i:1")
    RDPFile.writeline ("authentication level:i:2")
    RDPFile.writeline ("gatewayusagemethod:i:0")
    RDPFile.writeline ("gatewayprofileusagemethod:i:1")
    RDPFile.writeline ("gatewaycredentialssource:i:0")
    RDPFile.writeline ("full address:s:" & sName)
    RDPFile.writeline ("remoteapplicationprogram:s:||" & sShell)
    RDPFile.writeline ("gatewayhostname:s:")
    RDPFile.writeline ("remoteapplicationname:s:" & sString)
    RDPFile.writeline ("screen mode id:i:2")
    RDPFile.writeline ("desktopwidth:i:" & resy)
    RDPFile.writeline ("desktopheight:i:" & resx)
    RDPFile.writeline ("winposstr:s:0,3,0,0,800,600")
    RDPFile.writeline ("compression:i:1")
    RDPFile.writeline ("keyboardhook:i:2")
    RDPFile.writeline ("audiocapturemode:i:0")
    RDPFile.writeline ("videoplaybackmode:i:1")
    RDPFile.writeline ("connection type:i:2")
    RDPFile.writeline ("displayconnectionbar:i:1")
    RDPFile.writeline ("disable wallpaper:i:1")
    RDPFile.writeline ("allow desktop composition:i:0")
    RDPFile.writeline ("disable full window drag:i:1")
    RDPFile.writeline ("disable menu anims:i:1")
    RDPFile.writeline ("disable themes:i:0")
    RDPFile.writeline ("disable cursor setting:i:0")
    RDPFile.writeline ("bitmapcachepersistenable:i:1")
    RDPFile.writeline ("audiomode:i:0")
    RDPFile.writeline ("redirectdirectx:i:1")
    RDPFile.writeline ("autoreconnection enabled:i:1")
    RDPFile.writeline ("prompt for credentials:i:0")
    RDPFile.writeline ("negotiate security layer:i:1")
    RDPFile.writeline ("remoteapplicationicon:s:")
    RDPFile.writeline ("shell working directory:s:")
    RDPFile.writeline ("use redirection server name:i:0")
    RDPFile.close
    End Function
    
    
    '============ Function Create RdpFile ============
    Function CreateRDPFile(sString, sName, sShell)
    spath = DesktopPath & "\" & sString & ".rdp"
    
    ' проверяем наличие такого же файла - если есть - удаляем его'
    
    If m_FSO.FileExists(sPath) or m_FSO.FolderExists(sPath) Then
    m_FSO.DeleteFile (sPath),1
    End If
    
    Set RDPFile = m_FSO.CreateTextFile (spath, True)
    RDPFile.writeline ("screen mode id:i:2")
    RDPFile.writeline ("use multimon:i:0")
    RDPFile.writeline ("desktopwidth:i:" & resy)
    RDPFile.writeline ("desktopheight:i:" & resx)
    RDPFile.writeline ("session bpp:i:16")
    RDPFile.writeline ("winposstr:s:0,3,0,0,800,600")
    RDPFile.writeline ("compression:i:1")
    RDPFile.writeline ("keyboardhook:i:2")
    RDPFile.writeline ("audiocapturemode:i:0")
    RDPFile.writeline ("videoplaybackmode:i:1")
    RDPFile.writeline ("connection type:i:2")
    RDPFile.writeline ("displayconnectionbar:i:1")
    RDPFile.writeline ("disable wallpaper:i:1")
    RDPFile.writeline ("disable full window drag:i:1")
    RDPFile.writeline ("allow desktop composition:i:0")
    RDPFile.writeline ("allow font smoothing:i:0")
    RDPFile.writeline ("disable menu anims:i:1")
    RDPFile.writeline ("disable themes:i:1")
    RDPFile.writeline ("disable cursor setting:i:0")
    RDPFile.writeline ("bitmapcachepersistenable:i:1")
    RDPFile.writeline ("full address:s:" & sName)
    RDPFile.writeline ("audiomode:i:2")
    RDPFile.writeline ("redirectprinters:i:0")
    RDPFile.writeline ("redirectcomports:i:0")
    RDPFile.writeline ("redirectsmartcards:i:0")
    RDPFile.writeline ("redirectclipboard:i:1")
    RDPFile.writeline ("redirectposdevices:i:0")
    RDPFile.writeline ("redirectdirectx:i:1")
    RDPFile.writeline ("autoreconnection enabled:i:1")
    RDPFile.writeline ("authentication level:i:0")
    RDPFile.writeline ("prompt for credentials:i:0")
    RDPFile.writeline ("negotiate security layer:i:1")
    RDPFile.writeline ("remoteapplicationmode:i:0")
    RDPFile.writeline ("alternate shell:s:" & sShell)
    RDPFile.writeline ("shell working directory:s:")
    RDPFile.writeline ("gatewayhostname:s:")
    RDPFile.writeline ("gatewayusagemethod:i:4")
    RDPFile.writeline ("gatewaycredentialssource:i:4")
    RDPFile.writeline ("gatewayprofileusagemethod:i:0")
    RDPFile.writeline ("promptcredentialonce:i:1")
    RDPFile.writeline ("drivestoredirect:s:*")
    RDPFile.writeline ("use redirection server name:i:0")
    RDPFile.close
    End Function
    
    '=====================================================
    '============ Function CheckGroups ===================
    
    Function CheckGroups(ADSPath)
    Dim objUser, arrMemberOf
    Const E_ADS_PROPERTY_NOT_FOUND = &h8000500D
    LevelCount = LevelCount + 1
    if ( LevelCount >= MaxLevelCount) then
    LevelCount = LevelCount - 1
    return LevelCount
    end If
    Set objUser = GetObject (ADSPath)
    On Error Resume Next
    arrMemberOf = objUser.GetEx("memberOf")
    If Err.Number = E_ADS_PROPERTY_NOT_FOUND Then
    LevelCount = LevelCount - 1
    return LevelCount
    Else
    For Each Group in arrMemberOf
    ADSGroup = "LDAP://" & Group
    CheckGroups(ADSGroup)
    ' WScript.Echo "Extra=" & LevelCount
    Set objGroup = GetObject ( ADSGroup )
    
    If(GetPrefixNameGroup(objGroup.CN) = "RemApps_") Then
    Set objGroup = GetObject ( "LDAP://" & Group)
    LinkName = GetLinkNameGroup(objGroup.CN)
    LinkServer = objGroup.description
    LinkProgram = objGroup.info
    LinkResult = CreateRemAppsFile (LinkName, LinkServer, LinkProgram)
    end If
    
    If(GetPrefixNameGroup(objGroup.CN) = "RDP_") Then
    Set objGroup = GetObject ( "LDAP://" & Group)
    LinkName = GetLinkNameGroup(objGroup.CN)
    LinkServer = objGroup.description
    LinkProgram = objGroup.info
    LinkResult = CreateRDPFile (LinkName, LinkServer, LinkProgram)
    end If
    
    Next
    End If
    LevelCount = LevelCount - 1
    End Function</spoiler>


    Следующий код делает почти тоже самое что и скрипт автора топика, но я не проверяю установлена ли 1С и формирую файлы с списками баз в профиле пользователя каждый раз при входе, предварительно их удаляя. В описании группы название базы в списке баз и в заметках параметры подключения к базе. Скрипт не мой, просил сделать на фрилансе, поэтому если кто то узнает свой код — еще раз примите благодарности, несколько лет не знаю горя.

    Код
    ' Префикс названий групп
    prefix_1c = "1c_"
    
    ' Получаем имя пользователя
    set info = CreateObject( "ADSystemInfo" )
    
    ' Получаем учетную запись
    set user = GetObject( "LDAP://" & info.UserName )
    
    ' Создаем файловые потоки
    set res_81 = CreateObject( "ADODB.Stream" )
    res_81.Type = 2
    res_81.Charset = "UTF-8"
    res_81.Open
    res_81.Position = 0
    
    set res_82 = CreateObject( "ADODB.Stream" )
    res_82.Type = 2
    res_82.Charset = "UTF-8"
    res_82.Open
    res_82.Position = 0
    
    memberOf = user.memberOf
    
    ' Просматривает список групп
    If (not (IsEmpty(memberOf)) ) then
      For Each item in user.memberOf
        set group = GetObject( "LDAP://" & item )
    
        if (InStr( group.CN, prefix_1c ) = 1) then
          if (InStr( group.info, "Version=8.1" ) > 0) then
            res_81.WriteText( "[" & group.Description & "]" & Chr(13) & Chr(10) )
            res_81.WriteText( group.info & Chr(13) & Chr(10) )
          end if
    
          if (InStr( group.info, "Version=8.2" ) > 0) then
            res_82.WriteText( "[" & group.Description & "]" & Chr(13) & Chr(10) )
            res_82.WriteText( group.info & Chr(13) & Chr(10) )
          end if
        end if
      next
    end if
    
    ' Ищем путь до файлов
    set shell = CreateObject( "WScript.Shell" )
    appdata = shell.ExpandEnvironmentStrings( "%APPDATA%" )
    
    ' Создать папки
    set fso = CreateObject( "Scripting.FileSystemObject" )
    
    if (not fso.FolderExists( appdata + "\1C" )) then
      fso.CreateFolder( appdata + "\1C" )
    end if
    if (not fso.FolderExists( appdata + "\1C\1Cv81" )) then
      fso.CreateFolder( appdata + "\1C\1Cv81" )
    end if
    if (not fso.FolderExists( appdata + "\1C\1CEStart" )) then
      fso.CreateFolder( appdata + "\1C\1CEStart" )
    end if
    
    
    ' И пишем файлы туда
    
    
    res_81.SaveToFile appdata & "\1C\1Cv81\ibases.v8i", 2
    res_81.Close
    
    res_82.SaveToFile appdata & "\1C\1CEStart\ibases.v8i", 2
    res_82.Close</spoiler>
  • 0
    Все делается намного проще, всем делается ярлык на 1cestart.exe
    рядом с ним файл
    1CESCmn.cfg
    в него прописываем все файлы описания имеющихся баз перечислением:

    CommonInfoBases=\\xxxxx\share$\base1.v8i
    CommonInfoBases=\\xxxxx\share$\base2.v8i
    CommonInfoBases=\\xxxxx\share$\base3.v8i

    Или через группы, или напрямую даем права на чтение нужным пользователям на файлы \\xxxxx\share$\base1.v8i

    При запуске 1cestart.exe в список информационных баз у пользователя добавятся только те, на которые у него есть права на чтение.
    Ни каких скриптов, права можно менять без перелогона пользователя и вообще удобно.
    • 0
      права можно менять без перелогона пользователя

      Это справедливо если права менять на файле v8i, добавляя очередную учётку с правами на чтение, однако при большом количестве баз и/или пользователей, гораздо правильнее добавлять пользователя в группу, у которой есть право на чтение нужных файлов, а при этом перелогин будет уже необходим.
      С другой стороны, генерацию cfg-файла можно организовать и по запросу (дать юзеру ссылку на отдельный скрипт для этого или самому запустить отдельный скрипт с указанием имени комп-а и пользователя), без перелогина.

Только зарегистрированные пользователи могут оставлять комментарии. Войдите, пожалуйста.