Option Explicit
Call WorkWithSigns(ThisObject)
'==============================================================================
' Выполнить выбранные пользователем действия над коллекцией подписей объекта
' Выполнять скрипт может только администратор объекта
'==============================================================================
Sub WorkWithSigns(Obj)
Dim SelDlg, RetVal, strAction, ArActions, SignCol
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 SignCol = Obj.Signs
'Выполнить все заданные действия
For Each strAction In SelDlg.Objects
If StrComp(strAction, ArActions(0))=0 Then
Call CreateSign(SignCol)
ElseIf StrComp(strAction, ArActions(1))=0 Then
Call SetSign(SignCol, Obj)
ElseIf StrComp(strAction, ArActions(2))=0 Then
Call RemoveSign(SignCol)
ElseIf StrComp(strAction, ArActions(3))=0 Then
Call ShowInfo(SignCol)
End If
Next
End Sub
'==============================================================================
'==============================================================================
'Создать пустую подпись на объекте
'==============================================================================
Sub CreateSign(SignCol)
Dim NewSign, StrSysName
'Проверить, существует ли системное имя типа; если нет - запросить повторный ввод
StrSysName = "SGN_TEST"
While (Not SignCol.Has(StrSysName))
StrSysName = InputBox("Введите другое сист. имя (" & StrSysName & " не найдено):",_
, StrSysName)
'Если диалог отменен или введена пустая строка, выйти из процедуры
If StrSysName = "" Then Exit Sub
Wend
'Создать новую пустую подпись в коллекции
Set NewSign = SignCol.Create(StrSysName)
ThisApplication.DebugPrint("Номер новой подписи в коллекции - " & SignCol.Index(NewSign))
End Sub
'==============================================================================
'==============================================================================
' Вывести диалог инициализации подписи c указанным SysID на указанном объекте
'==============================================================================
Sub SetSign(SignCol, Obj)
Dim StrPass, StrSysName, Sign, RetVal, SimpleDlg
'Запросить системное имя типа
StrSysName = InputBox("Введите системное имя подписи для инициализации:",_
, "SGN_TEST")
'Если диалог отменен или введена пустая строка, выйти из процедуры
If StrSysName = "" Then Exit Sub
'Получить ссылку на первую пустую (неинициализированную) подпись нужного типа
For Each Sign In SignCol
If (Sign.SignDef.SysName=StrSysName) And Sign.Empty Then Exit For
Next
'Если на объекте нет "пустых" подписей нужного типа, выйти из процедуры
'(вызов диалога для инициализированной подписи приведет к ошибке)
If (Not SignCol.Has(StrSysName)) Or (IsEmpty(Sign)) Then
MsgBox "На объекте не найдено пустых подписей типа " & StrSysName & ".",_
vbExclamation
Exit Sub
End If
'Запросить пароль на подпись у текущего пользователя
Set SimpleDlg = ThisApplication.Dialogs.SimpleEditDlg
SimpleDlg.Type = tdmSimpleEditPassword
SimpleDlg.Caption = "Требуется пароль на подпись"
SimpleDlg.Prompt = "Пароль:"
RetVal = SimpleDlg.Show
If RetVal<> TRUE Then Exit Sub
StrPass = SimpleDlg.Text
'Подписываем текущим пользователем
On Error Resume Next
Sign.SetSign StrPass, ThisApplication.CurrentUser, Date
If Err<>0 Then MsgBox "Ошибка инициализации подписи (возможно, неверный пароль)."
'Существует возможность подписать подпись от имени другого пользователя
'при условии, что известен его пароль
'Obj.SetSign StrSigndefSysName, StrPass, SomeUser.Description
End Sub
'==============================================================================
'==============================================================================
'Удалить подпись с объекта.
'!!Инициализированную подпись может удалить только системный администратор,
'неинициализированную - администратор объекта или вышестоящий администратор.
'==============================================================================
Sub RemoveSign(SignCol)
Dim i, Sign, SelDlg, SignArray(), RetVal
'Заполнить массив "пустыми" подписями, если они есть в коллекции
i = -1
For Each Sign In SignCol
If Sign.Empty Then
i = i + 1
Redim Preserve SignArray(i)
Set SignArray(i) = Sign
End If
Next
'Открыть диалог выбора, передав на вход массив "пустых" подписей
Set SelDlg = ThisApplication.Dialogs.SelectDlg
SelDlg.SelectFrom = SignArray
SelDlg.Caption = "Подписи на объекте"
SelDlg.Prompt = "Выберите подпись для удаления:"
RetVal = SelDlg.Show
'Если диалог отменен или ничего не выбрано...
If (RetVal <> TRUE) Or (UBound(SelDlg.Objects)<0) Then Exit Sub
'Удалить выбранные подписи
On Error Resume Next
For Each Sign In SelDlg.Objects
SignCol.Remove Sign
If Err<>0 Then
Msgbox "Ошибка удаления подписи " & Sign.Description, vbExclamation
Err=0
End If
Next
'Удалить выбранные подписи (второй проход)
For i = 0 to SignCol.Count - 1
If SignCol.Item(i).Empty Then
SignCol.Remove(SignCol.Item(i))
End If
Next
End Sub
'==============================================================================
'==============================================================================
' Вывести информацию обо всех подписях в коллекции
'==============================================================================
Sub ShowInfo(SignCol)
Dim StrInfo, Sign, bNotEmpty
For Each Sign In SignCol
With Sign
bNotEmpty = Not(.Empty)
StrInfo = .Description & Chr(13)
StrInfo = StrInfo & "Инициализирована: " & bNotEmpty & Chr(13)
If bNotEmpty Then
StrInfo = StrInfo & "Кем подписана: " & .Signer.Description & Chr(13)
StrInfo = StrInfo & "Доступ по роли: " & .SignerRoleDef.Description & Chr(13)
StrInfo = StrInfo & "От чьего имени стоит подпись: " & .SignedAs.Description & Chr(13)
StrInfo = StrInfo & "От какой даты стоит подпись: " & .Time & Chr(13)
StrInfo = StrInfo & "Системное время в момент установки: " & .SystemTim
'В логах отладчика выводим идентификатор подписи
ThisApplication.DebugPrint("Идентификатор подписи от " & .Time & " - " & .Handle)
End If
'Вывести информацию в окно сообщени
ThisApplication.AddNotify(StrInfo)
End With
Next
End Sub
'==============================================================================
Исходный текст