Исходный код

Option Explicit
Call WorkWithSignDefs()




'==============================================================================
' Выполнить выбранные пользователем действия над коллекцией типов подписей.
' Выполнять скрипт может только системный администратор
'==============================================================================
Sub WorkWithSignDefs()
        
        Dim SelDlg, RetVal, strAction, ArActions, SignDefsCol
        
        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 SignDefsCol = ThisApplication.SignDefs
        
        'Выполнить все заданные действия
        For Each strAction In SelDlg.Objects
                If StrComp(strAction, ArActions(0))=0 Then
                                                                                            Call CreateSignDef(SignDefsCol)
                ElseIf StrComp(strAction, ArActions(1))=0 Then
                                                                                            Call RemoveSignDef(SignDefsCol)
                ElseIf StrComp(strAction, ArActions(2))=0 Then
                                                                                            Call ShowInfo(SignDefsCol)
                End If
        Next
End Sub
'==============================================================================


'==============================================================================
'Создать новый тип подписи
'==============================================================================
Sub CreateSignDef(SignDefsCol)
        Dim NewSignDef, StrSysName, StrDescr, SelDlg, RetVal 
        
        'Запросить описание нового типа
        StrDescr = InputBox("Введите описание нового типа подписи:")
        'Если ничего не введено, выйти из процедуры
        If StrDescr="" Then Exit Sub
        
        'Проверить, существует ли системное имя типа; если да - запросить повторный ввод
        StrSysName = "SGN_TEST"
        While (SignDefsCol.Has(StrSysName))
                    StrSysName = InputBox("Введите другое сист. имя (" & StrSysName & " уже есть):",_
                                        , StrSysName)
                    'Если диалог отменен или введена пустая строка, выйти из процедуры
                    If StrSysName = "" Then Exit Sub
        Wend
        
        'Включим собственный перехват ошибок
        On Error Resume Next                        
        
        'Создать новый тип подписи в коллекции
        Set NewSignDef = SignDefsCol.Create
        'Задать значения свойствам нового типа
        With NewSignDef
                .Description = StrDescr
                .SysName = StrSysName
                .ShortDescription = "Test"
                
                'Дадим право инициализации новой подписи роли "Разработчик"
                .RoleDefs.Add ThisApplication.RoleDefs("ROLE_DEVELOPER")
        End With
        
        'Если была ошибка...
        If Err<>0 Then         MsgBox "Ошибка создания типа подписи " & StrSysName & "." &_
                                Chr(13) & "Код ошибки: " & Err, vbExclamation
End Sub
'==============================================================================


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

'==============================================================================
' Вывести информацию обо всех типах подписей приложения
'==============================================================================
Sub ShowInfo(SignDefsCol)
        Dim StrInfo, SDef, RoleDef
        
        For Each SDef In SignDefsCol
        With SDef
                StrInfo = .Description & Chr(13)
                StrInfo = StrInfo & "Краткое описание: " & .ShortDescription & Chr(13)
                StrInfo = StrInfo & "Системное имя: " & .SysName & Chr(13)
                StrInfo = StrInfo & "Каким ролям разрешена инициализация: " & Chr(13)
                
                For Each RoleDef In .RoleDefs
                        StrInfo = StrInfo & RoleDef.Description & Chr(13)
                Next
                
                'Вывести информацию в окно сообщений
                ThisApplication.AddNotify(StrInfo)
        End With
        Next
        
End Sub
'==============================================================================