TCreator

Класс TCreator служит для создания объектов и гарантирует освобождение объекта по выходу из области видимости. При использовании GetObject освобождение объектов непосредственно в скрипт-функции не требуется.

Пример использования

Option Explicit
Sub MyProcedure
 
  Dim Creator, F
  Set Creator = new TCreator
  Set F = Creator.GetObject(Application, "usrf_MyForm", "MyName")
  F.ShowModal
 
  ' высвобождать форму F вручную не требуется, так как она будет
  ' уничтожена автоматически в процессе уничтожения объекта Creator
  ' по завершении процедуры MyProcedure
 
End Sub

См. также статью Реализация конструкции try-finally на VBScript.

Исходный код

'Класс служит для создания объектов методом GetObject.
'Класс гарантирует освобождение объекта по завершению скрипта.
'При использьзовании GetObject освобождение объектов непосредственно в скрипт-функции не требуется,
'оно происходит автоматически при завершению скрипт-функции.
 
Private NextCreatorID
Private CreatorCnt
 
NextCreatorID = 0
CreatorCnt = 0
 
Class TCreator
  Private FCount
  Private FObjectArray()
  Private FID
 
  Public Sub DestroyAllObjects
    for I = UBound(FObjectArray) to LBound(FObjectArray) step -1
      if VarType(FObjectArray(I)) = vbObject then
        Designer.DestroyObject(FObjectArray(I))
        Set FObjectArray(I) = Nothing
      end if
    next
    FCount = -1
  End Sub
 
  Public Function GetObject(Params, ClassName, Name)
    FCount = FCount + 1
    if FCount > UBound(FObjectArray) then
      ReDim Preserve FObjectArray((UBound(FObjectArray) + 1) * 2 - 1)
    end if
    set FObjectArray(FCount) = Designer.CreateObject(Params, ClassName, Name)
    set GetObject = FObjectArray(FCount)
  End Function
 
  'Используется, в случае необходимости,
  'для уничтожения объктов созданных Креатором
  Public Sub DestroyObject(Object)
    for I = UBound(FObjectArray) to LBound(FObjectArray) step -1
      if VarType(FObjectArray(I)) = vbObject then
        if Addr(FObjectArray(I)) = Addr(Object) then
          Designer.DestroyObject(FObjectArray(I))
          Set FObjectArray(I) = Nothing
          exit sub
        end if
      end if
    next
 
    call Exception.Raise("Exception", "В списке не найден переданный объект.")
  End Sub
 
  Private Sub Class_Initialize
    ReDim FObjectArray(7)
    FCount = -1
    FID = NextCreatorID
    CreatorCnt = CreatorCnt + 1
    NextCreatorID = NextCreatorID + 1
    System.AddLogRecord "TCreator", "Created #" & FID & ", Total: " & CreatorCnt, 1, -1, "", False
  End Sub
 
  Private Sub Class_Terminate
    DestroyAllObjects
    CreatorCnt = CreatorCnt - 1
    System.AddLogRecord "TCreator", "Destroyed #" & FID & ", Total: " & CreatorCnt, 1, -1, "", False
  End Sub
End Class