TCreator

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

Class TCreator
  Private FCount
  Private FObjectArray()
  Private FFinallyCount
  Private FFinallyCode()
 
  Public Sub DestroyAllObjects
    for I = UBound(FObjectArray) to LBound(FObjectArray) step -1
      if VarType(FObjectArray(I)) = vbObject then
        FObjectArray(I).DestroyObject
        FObjectArray(I) = Empty
      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
          FObjectArray(I) = Empty
          Object.DestroyObject
          exit sub
        end if
      end if
    next
 
    call Exception.Raise("Exception", "В списке не найден переданный объект.")
  End Sub
 
  Public Function AddFinallyCode(ByRef S, ByRef Obj)
    FFinallyCount = FFinallyCount + 1
    if FFinallyCount > UBound(FFinallyCode, 1) then _
      ReDim Preserve FFinallyCode((UBound(FFinallyCode) + 1) * 2 - 1, 1)
    FFinallyCode(FFinallyCount, 0) = S
    if IsObject(Obj) then
      Set FFinallyCode(FFinallyCount, 1) = Obj
    else
      FFinallyCode(FFinallyCount, 1) = Obj
    end if
    AddFinallyCode = FFinallyCount
  End Function
 
  Public Sub DeleteFinallyCode(I)
    FFinallyCode(I, 0) = ""
    if IsObject(FFinallyCode(I, 1)) then _
      Set FFinallyCode(I, 1) = Nothing
  End Sub
 
  Public Sub ExecFinallyCode
    Dim I
    For I = LBound(FFinallyCode, 1) To UBound(FFinallyCode, 1)
      if FFinallyCode(I, 0) > "" then
        Execute Replace(FFinallyCode(I, 0), "<X>", "FFinallyCode(I, 1)")
        DeleteFinallyCode I
      end if
    Next
  End Sub
 
  Private Sub Class_Initialize
    ReDim FObjectArray(7)
    FCount = -1
    ReDim FFinallyCode(1, 1)
    FFinallyCount = -1
  End Sub
 
  Private Sub Class_Terminate
    ExecFinallyCode
    DestroyAllObjects
  End Sub
End Class