Исходный текст
Option Explicit
Call TestCmdCollection(ThisApplication.Shell.SelObjects)
'=====================================================================
' Найти команду Test в коллекции, если ее нет - создать, а затем удалить.
' Для выполнения скрипта нужны права системного администратора
'=====================================================================
Sub TestCmdCollection(Objects)
If Objects.Count = 0 Then
Msgbox "Нет выделенных объектов.", vbInformation
Exit Sub
End If
Dim Cmd, appCmds, objCmds, bExist, CmdID, Object, RetVal
Set Object = Objects(0)
CmdID = "CMD_TEST2"
Set Cmd = Nothing
'Получить ссылку на коллекцию команд приложения
Set appCmds = ThisApplication.Commands
' Если команда "Test" не найдена в коллекции, создать ее
If Not appCmds.Has(CmdID) Then
Set Cmd = appCmds.Create
Cmd.SysName = CmdID
Call FillCmdProperties(Cmd) 'определить свойства нового объекта...
bExist = False
Else 'иначе - получить ссылку на существующую команду
MsgBox "Команда " & CmdID & " существует" & Chr(13) & _
"в коллекции приложения под номером " & appCmds.Index(CmdID), vbInformation
Set Cmd = appCmds.Item(CmdID)
End If
'Получить коллекцию команд объекта, переданного в параметре процедуры
Set objCmds = Object.ObjectDef.Commands
'Наличие команды в коллекции можно проверить и через свойство Index
'(если объект не найден, свойство будет содержать -1)
If objCmds.Index(Cmd) < 0 Then
'Если команды нет в коллекции объекта, добавить ее. Метод никак не влияет
'ни на коллекцию типа объекта, ни на коллекции команд других объектов этого типа
objCmds.Add Cmd
MsgBox "Коллекция команд объекта " & Object.Description & Chr(13) & "содержит " _
& objCmds.Count & " элемент(ов) вместе с добавленной командой.", vbInformation
'Теперь удалить команду методом Remove (это приведет только к удалению
'ее только из коллекции объекта; в коллекции приложения она все еще есть)
objCmds.Remove Cmd
End If
'Если команда создана нами, удалить ее. Метод Erase удаляет информацию о команде
'из базы данных
If bExist <> True Then
RetVal = MsgBox("Удалить команду Test из приложения?", vbQuestion + vbYesNo)
If RetVal <> vbNo Then Cmd.Erase
End If
End Sub
'======================================================================
Sub FillCmdProperties(Cmd)
'Здесь определяются свойства нового объекта TDMSCommand
End Sub
'======================================================================