Option Explicit
Call TestFormsCollection(ThisObject)
'==============================================================================
' Выполнить одно из выбранных пользователем действий над коллекцией форм
' (нужны права системного администратора).
'==============================================================================
Sub TestFormsCollection(Obj)
Dim SelDlg, RetVal, strAction, ArActions, FCol, form
ArActions = Array("Создать форму", "Добавить форму к типу объекта", _
"Удалить форму из коллекции", "Вывести информацию о форме")
'Получить ссылку на коллекцию форм, определенную для объекта данного типа
Set FCol = Obj.ObjectDef.InputForms
'Если коллекция пустая, можно только добавить в нее форму или создать новую
'(обрежем массив возможных действий до 2х элементов)
If FCol.Count=0 Then ReDim Preserve ArActions(1)
'Предоставить пользователю выбрать действие
Set SelDlg = ThisApplication.Dialogs.SelectDlg
SelDlg.SelectFrom = ArActions
SelDlg.Prompt = "Выберите действие:"
RetVal = SelDlg.Show
'Если пользователь отменил диалог или ничего не выбрал, закончить работу.
'Диалог вернул массив, поскольку был инициализирован строковым массивом
If (RetVal <> TRUE) Or (UBound(SelDlg.Objects)<0) Then Exit Sub
'Выполнить все заданные действия
For Each strAction In SelDlg.Objects
If StrComp(strAction, ArActions(0))=0 Then
Call CreateForm(FCol)
ElseIf StrComp(strAction, ArActions(1))=0 Then
Call AddForm(FCol, SelDlg)
ElseIf StrComp(strAction, ArActions(2))=0 Then
Call RemoveForm(FCol)
ElseIf StrComp(strAction, ArActions(3))=0 Then
Call ShowInfo(FCol)
End If
Next
End Sub
'==============================================================================
'==============================================================================
'Создать форму в коллекции
'==============================================================================
Sub CreateForm(FCol)
Dim NewForm, StrRet, StrSysName, EditObjDlg
'Запросить описание создаваемой формы
StrRet = InputBox("Введите описание для создаваемой формы:")
'Если введена пустая строка, выйти из процедуры
If StrRet = "" Then Exit Sub
'Проверить, существует ли такое системное имя; если да - запросить другое
StrSysName = "FRM_TEST"
While FCol.Has(StrSysName)
StrSysName = InputBox("Введите другое сист. имя (такое уже есть):",, StrSysName)
Wend
'Отключить обработку ошибок
On Error Resume Next
'Создать новый объект TDMSForm в коллекции типа объекта. Новая форма
'автоматически добавляется также в коллекцию приложения.
Set NewForm = FCol.Create
NewForm.Description = StrRet
NewForm.Caption = "Тестовая форма"
NewForm.SysName = StrSysName
'Создадим небольшой скрипт для новой формы (обработка события BeforeClose)
NewForm.Script = "Sub Form_BeforeClose(Form, Obj, Cancel)" & Chr(13) & _
" MsgBox ""Good bye!""" & Chr(13) & "End Sub"
'Если была ошибка создания формы, сообщить
If Err<>0 Then
MsgBox "Ошибка создания формы """ & NewForm.SysName & """", vbExclamation
Else
'Показать форму
NewForm.Show
End If
End Sub
'==============================================================================
'==============================================================================
'Добавить форму в коллекцию
'==============================================================================
Sub AddForm(FCol, SelDlg)
Dim RetVal, ArSize, ArForms, frm, i
'Заполнить массив ссылками на формы ввода, созданные в приложении
ArSize = ThisApplication.InputForms.Count
ReDim ArForms(ArSize)
For i=0 To ArSize-1
Set ArForms(i) = ThisApplication.InputForms(i)
Next
'Открыть диалог выбора, передав на вход массив форм
SelDlg.SelectFrom = ArForms
SelDlg.Caption = "Формы ввода"
SelDlg.Prompt = "Выберите форму для добавления в коллекцию:"
RetVal = SelDlg.Show
'Если пользователь ничего не выбрал или отменил диалог, выйти из процедуры
If (Not RetVal) Or (UBound(SelDlg.Objects)<0) Then Exit Sub
'Отключить обработку ошибок (они могут возникнуть при добавлении формы)
On Error Resume Next
'Добавить выбранные формы в коллекцию
For Each frm In SelDlg.Objects
FCol.Add frm
'Если ошибка все-таки была, возможно форма уже в коллекции
If Err<>0 Then
MsgBox "Ошибка добавления формы """ & frm.Description & """" & Chr(13) &_
"(возможно, уже в коллекции).", vbExclamation
End If
Next
End Sub
'==============================================================================
'==============================================================================
'Удалить форму из коллекции
'==============================================================================
Sub RemoveForm(FCol)
Dim StrRet, index
'Запросить индекс формы для удаления. Он не должен превышать количество
'форм в коллекции
StrRet = InputBox("Введите индекс формы, которая должна быть удалена:" & Chr(13) &_
"(от 0 до " & FCol.Count-1 & "):")
'Если введено не-число или диалог отменен, выйти из процедуры
If (StrRet="") Or (Not IsNumeric(StrRet)) Then Exit Sub
'Получить введенный индекс
index = CLng(StrRet)
'Возможно, введенное число выходит за границы допустимого диапазона
If Not FCol.Has(index) Then
MsgBox "Задан недопустимый индекс.", vbExclamation
Exit Sub
End If
'Отключить обработку ошибок (они могут возникнуть при удалении формы)
On Error Resume Next
'Попытаться удалить форму
FCol.Remove FCol.Item(index)
'Если ошибка все-таки была, скорее всего это потому что форма используется.
If Err<>0 Then
MsgBox "Ошибка удаления формы (возможно, используется каким-либо объектом.)", _
vbExclamation
End If
End Sub
'==============================================================================
'==============================================================================
'Вывести информацию о форме с заданным индексом
'==============================================================================
Sub ShowInfo(FCol)
Dim StrRet, index, frm, StrInfo
'Запросить индекс формы. Он не должен превышать количество
'пользовательских значков в приложении
StrRet = InputBox("Введите индекс формы" & Chr(13) &_
"(от 0 до " & FCol.Count-1 & "):")
'Если введено не-число или диалог отменен, выйти из процедуры
If (StrRet="") Or (Not IsNumeric(StrRet)) Then Exit Sub
'Получить введенный индекс
index = CLng(StrRet)
'Возможно, введенное число выходит за границы допустимого диапазона
If Not FCol.Has(index) Then
MsgBox "Задан недопустимый индекс.", vbExclamation
Exit Sub
End If
'Получить ссылку на форму из коллекции
Set frm = FCol.Item(index)
'Сформировать строку с информацией
StrInfo = "Форма под номером " & index+1 & Chr(13)
StrInfo = StrInfo & "Описание: " & frm.Description & Chr(13)
StrInfo = StrInfo & "Системное имя: " & frm.SysName & Chr(13)
StrInfo = StrInfo & "Наличие скрипта: " & (frm.Script<>"") & Chr(13)
StrInfo = StrInfo & "Всего атрибутов: " & frm.Attributes.Count & Chr(13)
StrInfo = StrInfo & "Всего элементов управления: " & frm.Controls.Count
'Вывести информацию о форме в окно сообщений
ThisApplication.AddNotify StrInfo
End Sub
'==============================================================================
Исходный текст