Исходный текст

Option Explicit
Call WorkWithProfiles()


'==============================================================================
' Выполнить выбранные пользователем действия над коллекцией профилей пользователей
' Выполнять скрипт может только системный администратор
'==============================================================================
Sub WorkWithProfiles()
        
        Dim SelDlg, RetVal, strAction, ArActions, ProfCol
        
        ArActions = Array("Создать новый профиль", "Удалить профиль пользователя")
        
        'Предоставить пользователю выбрать действие 
        Set SelDlg = ThisApplication.Dialogs.SelectDlg
        SelDlg.SelectFrom = ArActions 
        SelDlg.Prompt = "Выберите действие:"
        RetVal = SelDlg.Show
        
        'Если пользователь отменил диалог или ничего не выбрал, закончить работу.
        'Диалог вернул массив, поскольку был инициализирован строковым массивом
        If (RetVal <> TRUE) Or (UBound(SelDlg.Objects)<0) Then Exit Sub
        
        'ПОлучить ссылку на коллекцию профилей, созданных в приложении
        Set ProfCol = ThisApplication.Profiles
        
        'Выполнить все заданные действия
        For Each strAction In SelDlg.Objects
                If StrComp(strAction, ArActions(0))=0 Then
                                                                                            Call CreateProfile(ProfCol)
                ElseIf StrComp(strAction, ArActions(1))=0 Then
                                                                                            Call RemoveProfile(ProfCol)
                End If
        Next
End Sub
'==============================================================================


'==============================================================================
'Создать новый    профиль пользователя
'==============================================================================
Sub CreateProfile(ProfCol)
        Dim StrRet, NewProfile, StrSysName 
        
        'Запросить описание нового профиля
        StrRet = InputBox("Введите описание нового пользовательского профиля:")
        
        'Если введена пустая строка или диалог отменен, выйти из процедуры
        If StrRet="" Then Exit Sub
        
        'Проверить, существует ли такое системное имя; если да - запросить другое
        StrSysName = "PROFILE_TEST"
        testdesc = "Тестовый прфоиль"
        While ProfCol.Has(StrSysName)
                    StrSysName = InputBox("Введите другое сист. имя (такое уже есть):",, StrSysName)
        Wend
        
        'Узнать точное количество тестовых профилей
        With ProfCol
            For i = 0 to .Count - 1
                    if .Item(i).Description = testdesc Then
                        MsgBox ("Системное имя тестового профиля - " & .Item(i).SysName)
                    End If
            Next
        End With
        
        'Создать новый пользовательский профиль
        Set NewProfile = ProfCol.Create
        'Присвоить ему системное имя
        NewProfile.SysName =  StrSysName  
        '... и описание
        NewProfile.Description =  StrRet
        
        'Сообщить результат
        MsgBox ("Новый профиль создан в коллекции c индексом " & ProfCol.Index(NewProfile))
        'В логах отладчика выводим идентификатор
        ThisApplication.DebugPrint("Идентификатор нового профиля - " & NewProfile.Handle)
End Sub
'==============================================================================


'==============================================================================
'Удалить профиль из приложения
'==============================================================================
Sub RemoveProfile(ProfCol)
        Dim StrRet, index, prf, RetVal
        
        'Запросить индекс профиля для удаления. Он не должен превышать количество 
        'профилей, созданных в приложении
        StrRet = InputBox("Введите индекс профиля, который должен быть удален:" & Chr(13) &_
                         "(от 0 до " & ProfCol.Count-1 & "):")
        
        'Если введено не-число или диалог отменен, выйти из процедуры
        If (StrRet="") Or (Not IsNumeric(StrRet)) Then Exit Sub
        
        'Получить введенный индекс
        index = CLng(StrRet)
        
        'Возможно, введенное число выходит за границы допустимого диапазона
        If Not ProfCol.Has(index) Then
                MsgBox "Задан недопустимый индекс.", vbExclamation
                Exit Sub
        End If
        
        'Запросить подтверждение удаления
        Set prf = ProfCol.Item(index)
        RetVal =     MsgBox("Удалить профиль """ & prf.Description & """?", vbQuestion + vbYesNo)    
        
        'Попытаться удалить профиль
        If RetVal <> vbNo Then
                'Отключить обработку ошибок (они могут возникнуть при попытке удалить, 
                'например, профиль "Все пользователи")
                On Error Resume Next
                
                'Удалить профиль из коллекции
                ProfCol.Remove(prf)
                
                'Если ошибка, сообщить об этом
                If Err<>0 Then
                        MsgBox "Ошибка удаления типа объекта """ & ODef.Description & """" & Chr(13)_
                                    & "(возможно, в системе созданы объекты данного типа.)"_
                                    & Chr(13) &    "Код ошибки: " & Err, vbExclamation     
                End If
        End If        
End Sub
'==============================================================================