Self-extracting VBA code and WithEvents tricks


Question

Is it possible to write a code which generates a set of MS Access 97's ready-to-run modules?

Answer

Yes, it is possible. Here is one of the solutions plus Withevents feature samples. See instructions inline.

Option Compare Database
Option Explicit

'*+
'
' Copyright (c) 1998 by Shamil Salakhetdinov, e-mail: shamil@marta.darts.spb.ru
'                    by Marek Kepinski,       e-mail: MKepinski@impaq.com.pl
'
' Sample code for an upcoming article temporary titled as:
'
' "Dynamic/dockable External Event Procedures/properties/methods (DEEP-objects)
'  in MS Access 97 (AKA sink-objects)" or
' "How deep are DEEPs"?
'
' Preface: This sample code/article are the results of authors' investigations
'          of MS Access 97's advanced features: custom class modules, early and late
'          methods binding, WithEvents objects and VBA code manipulation/generation.
'          It seems (was intentionally written) a little bit tricky way to activate
'          readers' own investigations of the subject.
'          Some of the points of the main subject of this code/article was announced/
'          discussed by authors on ACCESS-L discussion list. URL links for this discussion
'          are the following:
'
'          http://peach.ease.lsoft.com/scripts/wa.exe?A2=ind9807C&L=access-l&P=R21471
'          http://peach.ease.lsoft.com/scripts/wa.exe?A2=ind9807C&L=access-l&P=R21833
'          http://peach.ease.lsoft.com/scripts/wa.exe?A2=ind9807C&L=access-l&P=R26661
'          http://peach.ease.lsoft.com/scripts/wa.exe?A2=ind9807D&L=access-l&P=R831
'          http://peach.ease.lsoft.com/scripts/wa.exe?A2=ind9807D&L=access-l&P=R3124
'
' Instructions for sample code "activation":
'
'  1. Unzip sample code from DEEPs.zip archive into _Unpack_.txt VBA module.
'  2. Start MS Access 97
'  3. Create new .mdb file, say DEEPTest.mdb
'  4. Open New module
'  5. Delete options code lines from module
'  6. Insert _Unpack_.txt into this module
'  7. Save module as, e.g., _Unpack_
'  8. Close module
'  9. Open immediate window ( <Ctrl>+<G> )
' 10. Type Unpack<Enter> in it - you should get the sample's form and modules as a result
' 11. Type Test1<Enter> to run Test#1
' 12. Type Test2<Enter> to run Test#2
' 13. Type Test3<Enter> to run Test#3
' 14. Quit MS Access 97
'
' Notes:
'
' - Test#1 shows how single form instance can be opened usual way using DoCmd.OpenForm but
'      with all the code (including event processing one) placed into an external custom
'      class module...
' - Test#2 shows how multiple form instances can be opened object way...
' - Test#3 is a just a combination of Test#1 and Test#2...
' - If you look through the class module code of frmDEEPTest form you'll find that it has
'      property get function. This function isn't necessary to use DEEPs - it is placed in
'      form's module to show one of the possible ways to get reference to form's DEEP-object.
'      To be DEEP-active form *should* have class module but it can be empty (to get empty
'      form's class module open form in design view, open its module, delete all lines from it
'      and save it).
' -  You can test also codeless front-end form using this sample code - to get such form do the
'    following:
'
'  1. Create an front-end .mdb file, say, MyFe.mdb
'  2. Import frmDEEPTest into it
'  3. Open frmDEEPTest in design mode and delete all the code from it
'  4. Go Tools -> References -> Browse to set reference to DEEPTest.MDB
'  5. Save and close frmDEEPTest
'  6. Open frmDEEPTest in normal mode.
'  7. You can also run Test1,2,3 from front-end .MDB to test "back-end"/library forms activation.
'
'  to be continued...
'
'*+

Public Sub Unpack()
    DEEPTestUnPack True
End Sub

Private Sub DEEPTestUnPack(Optional ByVal vblnGen As Boolean = False)
    Dim dbs As Database
    Dim mdl As Module
    Dim strUnpackMdlName As String
    Dim colModules As New Collection
    Dim colLines As Collection
    Dim lngLinesCnt As Long
    Dim strLine As String
    Dim strMdlName As String
    Dim blnGen As Boolean
    
    blnGen = vblnGen
    
    If blnGen Then DoCmd.Hourglass True
    If blnGen Then DoCmd.Echo False, "Generating test objects..."
    
    Set dbs = CodeDb()
    If vblnGen Then
       DoCmd.OpenModule dbs.Containers("Modules").Documents(0).Name
    End If
    
    Set mdl = Modules(0)
    strUnpackMdlName = mdl.Name
    
    strMdlName = ""
    For lngLinesCnt = 1 To mdl.CountOfLines
        strLine = mdl.Lines(lngLinesCnt, 1)
        If Len(strLine) >= 6 Then
           If Left(strLine, 6) = "'//SOM" Then
             Set colLines = New Collection
             strMdlName = Trim(Mid(strLine, 7))
             colLines.Add "'" & Mid(strLine, 8), Mid(strLine, 2, 5)
           ElseIf Left(strLine, 6) = "'//EOM" Then
             colModules.Add colLines, strMdlName
           Else
             If strMdlName <> "" Then
               colLines.Add Mid(strLine, 8), Mid(strLine, 2, 5)
             End If
           End If
        End If
    Next

    DoCmd.Close acModule, mdl.Name
    
    For Each colLines In colModules
       strMdlName = Mid(colLines(1), 2)
       If blnGen Then smsModuleCreate colLines, strMdlName
    Next
    
    If blnGen Then smsFormCreate
    
    CleanUp strUnpackMdlName
    
    'If blnGen Then DoCmd.RunCommand acCmdCompileAllModules
    If blnGen Then DoCmd.Echo True
    If blnGen Then DoCmd.Hourglass False
    
End Sub

Private Function CleanUp(ByVal vstrMdlname As String)
    Dim frm As Form
    Dim mdl As Module
    
    Set frm = CreateForm()
    
    DoCmd.RunCommand acCmdViewCode
    Set mdl = Modules("Form_" & frm.Name)
    mdl.DeleteLines 1, mdl.CountOfLines
    
     
    mdl.InsertText "Private Sub Form_Timer()"
    mdl.InsertText "    on error resume next"
    mdl.InsertText "    DoCmd.DeleteObject acModule, """ & vstrMdlname & """"
    mdl.InsertText "    docmd.Close acForm ,Me.name,acSaveNo"
    mdl.InsertText "End sub"
    DoCmd.Close acModule, mdl.Name
    
    frm.OnTimer = "[Event Procedure]"
    frm.TimerInterval = 1000
    DoCmd.OpenForm frm.Name, acNormal, , , , acHidden
End Function

Private Function smsFormCreate()
    Dim frm As Form
    Dim strAutoFrmName As String
    Dim ctl As Control
    Dim mdl As Module
    
    Set frm = CreateForm()
    Set ctl = CreateControl(frm.Name, acCommandButton)
    ctl.Name = "cmdOk"
    Set ctl = CreateControl(frm.Name, acLabel)
    ctl.Name = "lblMsg"
    Set ctl = CreateControl(frm.Name, acRectangle)
    ctl.Name = "shpFrame"
    DoCmd.Restore
    smsFormPrpsSet frm
    
    DoCmd.RunCommand acCmdViewCode
    
    Set mdl = Modules("Form_" & frm.Name)
    mdl.DeleteLines 1, mdl.CountOfLines
    mdl.InsertText "Public Property Get DEEP() As Object 'clsFormDEEP"
    mdl.InsertText "    Set DEEP = FormDEEP(Me)"
    mdl.InsertText "End Property"
    
    frm.OnOpen = "=smsFormAndDEEPsCheckIn([Form])"
    frm.OnClose = "=smsFormAndDEEPsCheckOut([Form])"
    
    strAutoFrmName = frm.Name
    DoCmd.SetWarnings False
    DoCmd.Close acForm, strAutoFrmName, acSaveYes
    DoCmd.Rename "frmDEEPTest", acForm, strAutoFrmName
    DoCmd.SetWarnings True

End Function

Private Function smsFormPrpsSet(ByRef rfrm As Form)
    Dim ctl As Control
    With rfrm
       .DefaultView = 0               'Single Form
       .ViewsAllowed = 1              ' Form
       .ScrollBars = 0                ' neither
       .RecordSelectors = False
       .NavigationButtons = False
       .DividingLines = False
       .AutoResize = True
       .AutoCenter = True
       .BorderStyle = 1               ' Thin
       .ControlBox = False
       .MinMaxButtons = 0             ' None
       .CloseButton = False
       .Cycle = 1                     ' Current record
       .GridX = 5
       .GridY = 5
       
       .PopUp = True
       
       .InsideWidth = 4530
       .InsideHeight = 3045
       
       .Width = 4530
       .Section(0).Height = 3105
       .Caption = "DEEPs test form"
    End With

    Set ctl = rfrm![cmdOk]
    With ctl
       .Name = "cmdOK"
       .Caption = "OK"
       .Left = 1815
       .Top = 2310
       .Width = 1140
       .Height = 510
    End With

    Set ctl = rfrm![lblMsg]
    With ctl
       .Name = "lblMsg"
       .Caption = "1 second left to start test..."
       .Left = 390
       .Top = 375
       .Width = 3675
       .Height = 1605
       .FontName = "MS Sans Serif"
       .FontSize = 9
       .FontBold = True
       .TextAlign = 2       ' Center
    End With
    
    Set ctl = rfrm![shpFrame]
    With ctl
       .Name = "shpFrame"
       .Left = 330
       .Top = 315
       .Width = 3900
       .Height = 1740
       .SpecialEffect = 3
    End With
End Function

Public Function smsModuleCreate(ByRef rcolModuleLines As Collection, ByVal vstrModuleName As String)
    Dim mdl As Module
    Dim strCode As String
    Dim strAutoMdlName As String
    Dim varLine As Variant
    
    Select Case Left(vstrModuleName, 3)
    Case "bas":
       DoCmd.RunCommand acCmdNewObjectModule
    Case "cls":
       DoCmd.RunCommand acCmdNewObjectClassModule
    End Select
    
    Set mdl = Modules(Modules.Count - 1)
    mdl.DeleteLines 1, mdl.CountOfLines

    For Each varLine In rcolModuleLines
        mdl.InsertText varLine
    Next
    
    strAutoMdlName = mdl.Name
    
    DoCmd.SetWarnings False
    DoCmd.Close acModule, strAutoMdlName, acSaveYes
    DoCmd.Rename vstrModuleName, acModule, strAutoMdlName
    DoCmd.SetWarnings True
    
End Function


'//SOP
'//SOM bas_Description
'00001 '*+
'00002 '
'00003 ' Copyright (c) 1998 by Shamil Salakhetdinov, e-mail: shamil@marta.darts.spb.ru
'00004 '                    by Marek Kepinski,       e-mail: MKepinski@impaq.com.pl
'00005 '
'00006 ' Sample code for an upcoming article temporary titled as:
'00007 '
'00008 ' "Dynamic/dockable External Event Procedures/properties/methods (DEEP-objects)
'00009 '  in MS Access 97 (AKA sink-objects)" or
'00010 ' "How deep are DEEPs"?
'00011 '
'00012 ' Preface: This sample code/article are the results of authors' investigations
'00013 '          of MS Access 97's advanced features: custom class modules, early and late
'00014 '          methods binding, WithEvents objects and VBA code manipulation/generation.
'00015 '          It seems (was intentionally written) a little bit tricky way to activate
'00016 '          readers' own investigations of the subject.
'00017 '          Some of the points of the main subject of this code/article was announced/
'00018 '          discussed by authors on ACCESS-L discussion list. URL links for this discussion
'00019 '          are the following:
'00020 '
'00021 '          http://peach.ease.lsoft.com/scripts/wa.exe?A2=ind9807C&L=access-l&P=R21471
'00022 '          http://peach.ease.lsoft.com/scripts/wa.exe?A2=ind9807C&L=access-l&P=R21833
'00023 '          http://peach.ease.lsoft.com/scripts/wa.exe?A2=ind9807C&L=access-l&P=R26661
'00024 '          http://peach.ease.lsoft.com/scripts/wa.exe?A2=ind9807D&L=access-l&P=R831
'00025 '          http://peach.ease.lsoft.com/scripts/wa.exe?A2=ind9807D&L=access-l&P=R3124
'00026 '
'00027 ' Instructions for sample code "activation":
'00028 '
'00029 '  1. Unzip sample code from DEEPs.zip archive into _Unpack_.txt VBA module.
'00030 '  2. Start MS Access 97
'00031 '  3. Create new .mdb file, say DEEPTest.mdb
'00032 '  4. Open New module
'00033 '  5. Delete options code lines from module
'00034 '  6. Insert _Unpack_.txt into this module
'00035 '  7. Save module as, e.g., _Unpack_
'00036 '  8. Close module
'00037 '  9. Open immediate window ( <Ctrl>+<G> )
'00038 ' 10. Type Unpack<Enter> in it - you should get the sample's form and modules as a result
'00039 ' 11. Type Test1<Enter> to run Test#1
'00040 ' 12. Type Test2<Enter> to run Test#2
'00041 ' 13. Type Test3<Enter> to run Test#3
'00042 ' 14. Quit MS Access 97
'00043 '
'00044 ' Notes:
'00045 '
'00046 ' - Test#1 shows how single form instance can be opened usual way using DoCmd.OpenForm but
'00047 '      with all the code (including event processing one) placed into an external custom
'00048 '      class module...
'00049 ' - Test#2 shows how multiple form instances can be opened object way...
'00050 ' - Test#3 is a just a combination of Test#1 and Test#2...
'00051 ' - If you look through the class module code of frmDEEPTest form you'll find that it has
'00052 '      property get function. This function isn't necessary to use DEEPs - it is placed in
'00053 '      form's module to show one of the possible ways to get reference to form's DEEP-object.
'00054 '      To be DEEP-active form *should* have class module but it can be empty (to get empty
'00055 '      form's class module open form in design view, open its module, delete all lines from it
'00056 '      and save it).
'00057 ' -  You can test also codeless front-end form using this sample code - to get such form do the
'00058 '    following:
'00059 '
'00060 '  1. Create an front-end .mdb file, say, MyFe.mdb
'00061 '  2. Import frmDEEPTest into it
'00062 '  3. Open frmDEEPTest in design mode and delete all the code from it
'00063 '  4. Go Tools -> References -> Browse to set reference to DEEPTest.MDB
'00064 '  5. Save and close frmDEEPTest
'00065 '  6. Open frmDEEPTest in normal mode.
'00066 '  7. You can also run Test1,2,3 from front-end .MDB to test "back-end"/library forms activation.
'00067 '
'00068 '  to be continued...
'00069 '
'00070 '*+
'//EOM bas_Description
'//SOM bas_Tests
'00001 Option Compare Database
'00002 Option Explicit
'00003
'00004 Public Sub Test1()
'00005     DoCmd.OpenForm "frmDeepTest", acNormal
'00006 End Sub
'00007
'00008 Public Sub Test2()
'00009     Dim frm1 As New Form_frmDEEPTest
'00010     Dim frm2 As New Form_frmDEEPTest
'00011     Dim frm3 As New Form_frmDEEPTest
'00012
'00013     FormDEEP(frm1).mtdTestDurationReset 10
'00014     frm1.Visible = True
'00015     If frm1.PopUp = False Then
'00016        DoCmd.MoveSize 200, 200
'00017     Else
'00018        DoCmd.MoveSize 200, 1100
'00019     End If
'00020
'00021     frm2.DEEP.mtdTestDurationReset 7
'00022     frm2.Visible = True
'00023     If frm2.PopUp = False Then
'00024        DoCmd.MoveSize 500, 500
'00025     Else
'00026        DoCmd.MoveSize 500, 1400
'00027     End If
'00028
'00029     FormDEEP(frm3).mtdTestDurationReset 14
'00030     frm3.Visible = True
'00031     If frm3.PopUp = False Then
'00032        DoCmd.MoveSize 800, 800
'00033     Else
'00034        DoCmd.MoveSize 800, 1700
'00035     End If
'00036 End Sub
'00037
'00038 Public Sub Test3()
'00039     Test1
'00040     Test2
'00041 End Sub
'//EOM bas_Tests
'//SOM basHelpers
'00001 Option Compare Database
'00002 Option Explicit
'00003
'00004 Public pobjFormsRegistry As New clsFormsRegistry
'00005 Public pobjDEEPsRegistry As New clsDEEPsRegistry
'00006
'00007 Public Function smsFormAndDEEPsCheckIn(ByRef rfrm As Form)
'00008     pobjFormsRegistry.CheckIn rfrm, FormId(rfrm)
'00009
'00010     ObjDeepDock rfrm, New clsFormDEEP
'00011     ObjDeepDock rfrm![cmdOk], New clsCmdCtlDEEP
'00012     ObjDeepDock rfrm![lblMsg], New clsLblCtlDEEP
'00013     ObjDeepDock rfrm![lblMsg], New clsLastLblCtlInQueue, 1
'00014     ObjDeepDock rfrm![shpFrame], New clsShpCtlDEEP
'00015 End Function
'00016
'00017 Public Function smsFormAndDEEPsCheckOut(ByRef rfrm As Form)
'00018     ObjDeepUnDock rfrm![shpFrame]
'00019     ObjDeepUnDock rfrm![lblMsg], 1
'00020     ObjDeepUnDock rfrm![lblMsg]
'00021     ObjDeepUnDock rfrm![cmdOk]
'00022     ObjDeepUnDock rfrm
'00023
'00024     pobjFormsRegistry.CheckOut rfrm, FormId(rfrm)
'00025 End Function
'00026
'00027 Public Property Get FormId(ByRef rfrm As Object, Optional ByVal vintDEEPIdx As Integer = 0) As String
'00028     FormId = CStr(rfrm.Hwnd) & "." & CStr(vintDEEPIdx)
'00029 End Property
'00030
'00031 Public Property Get FormDEEP(ByRef rfrm As Form) As clsFormDEEP
'00032     Set FormDEEP = pobjDEEPsRegistry.Item(FormId(rfrm))
'00033 End Property
'00034
'00035 Public Property Get CtlId(ByRef rctl As Object, Optional ByVal vintDEEPIdx As Integer = 0) As String
'00036     Dim frm As Object
'00037     Dim ctl As Object
'00038
'00039     Set ctl = rctl
'00040     While Not TypeOf ctl.Parent Is Form
'00041         Set ctl = ctl.Parent
'00042     Wend
'00043     Set frm = ctl.Parent
'00044     CtlId = ctl.Name & CStr(frm.Hwnd) & "." & CStr(vintDEEPIdx)
'00045 End Property
'00046
'00047 Public Property Get CmdCtlDEEP(ByRef rcmd As CommandButton) As clsCmdCtlDEEP
'00048     Set CmdCtlDEEP = pobjDEEPsRegistry.Item(CtlId(rcmd))
'00049 End Property
'00050
'00051 Public Property Get LblCtlDEEP(ByRef rlbl As Label) As clsLblCtlDEEP
'00052     Set LblCtlDEEP = pobjDEEPsRegistry.Item(CtlId(rlbl))
'00053 End Property
'00054
'00055 Public Property Get ShpCtlDEEP(ByRef rshp As Rectangle) As clsShpCtlDEEP
'00056     Set ShpCtlDEEP = pobjDEEPsRegistry.Item(CtlId(rshp))
'00057 End Property
'00058
'00059 Public Property Get ControlDEEP(ByRef rctl As Control) As Object
'00060     Set ControlDEEP = pobjDEEPsRegistry.Item(CtlId(rctl))
'00061 End Property
'00062
'00063 Public Property Get ObjId(ByRef robj As Object, Optional ByVal vintDEEPIdx As Integer = 0) As String
'00064     If TypeOf robj Is Form Then
'00065         ObjId = FormId(robj, vintDEEPIdx)
'00066     Else
'00067         ObjId = CtlId(robj, vintDEEPIdx)
'00068     End If
'00069 End Property
'00070
'00071 Private Function ObjDeepDock(ByRef robj As Object, ByRef robjDeep As Object, Optional ByVal vintDEEPIdx As Integer = 0)
'00072     robjDeep.Dock robj
'00073     pobjDEEPsRegistry.CheckIn robjDeep, ObjId(robj, vintDEEPIdx)
'00074 End Function
'00075
'00076 Private Function ObjDeepUnDock(ByRef robj As Object, Optional ByVal vintDEEPIdx As Integer = 0)
'00077     Dim objDeep As Object
'00078
'00079     Set objDeep = pobjDEEPsRegistry.Item(ObjId(robj, vintDEEPIdx))
'00080     objDeep.UnDock
'00081     pobjDEEPsRegistry.CheckOut objDeep, ObjId(robj, vintDEEPIdx)
'00082 End Function
'00083
'00084
'//EOM basHelpers
'//SOM clsCmdCtlDEEP
'00001 Option Compare Database
'00002 Option Explicit
'00003
'00004 Private WithEvents mcmd As CommandButton
'00005
'00006 Public Function Dock(ByRef rcmd As CommandButton)
'00007     Set mcmd = rcmd
'00008     rcmd.OnClick = "[Event procedure]"
'00009 End Function
'00010
'00011 Public Function UnDock()
'00012     mcmd.OnClick = ""
'00013     Set mcmd = Nothing
'00014 End Function
'00015
'00016 Private Sub mcmd_Click()
'00017     mcmd.Parent.TimerInterval = 0
'00018     MsgBox "Button [" & mcmd.Caption & "] clicked.@ @", vbInformation + vbOKOnly
'00019     FormDEEP(mcmd.Parent).mtdClose
'00020 End Sub
'00021
'//EOM clsCmdCtlDEEP
'//SOM clsDEEPsRegistry
'00001 Option Compare Database
'00002 Option Explicit
'00003
'00004 Private mobjDEEPsRegistry As New clsObjectRegistry
'00005
'00006 Private Sub Class_Terminate()
'00007     Set mobjDEEPsRegistry = Nothing
'00008 End Sub
'00009
'00010 Public Function CheckIn(ByRef robjDeep As Object, ByVal vvarDEEPId As Variant)
'00011     mobjDEEPsRegistry.CheckIn robjDeep, vvarDEEPId
'00012 End Function
'00013
'00014 Public Function CheckOut(ByRef robjDeep As Object, ByVal vvarDEEPId As Variant)
'00015     mobjDEEPsRegistry.CheckOut robjDeep, vvarDEEPId
'00016 End Function
'00017
'00018 Public Property Get Item(ByVal vvarDEEPId As Variant) As Variant
'00019     Set Item = mobjDEEPsRegistry.Item(vvarDEEPId)
'00020 End Property
'//EOM clsDEEPsRegistry
'//SOM clsFormDEEP
'00001 Option Compare Database
'00002 Option Explicit
'00003
'00004 Private Const mclngTimerInterval As Long = 1000
'00005 Private Const mcintTestDuration As Integer = 15
'00006
'00007 Private WithEvents mfrm As Form
'00008 Private mintTestDuration As Integer
'00009
'00010 Public Function Dock(ByRef rfrm As Form)
'00011     Dim frm As Form
'00012     Dim intIdx As Integer
'00013     Dim strCaption As String
'00014
'00015     Set mfrm = rfrm
'00016     mfrm.OnTimer = "[Event procedure]"
'00017     mfrm.TimerInterval = mclngTimerInterval
'00018     mintTestDuration = mcintTestDuration
'00019     strCaption = "(Hwnd = " & mfrm.Hwnd & ") " & mfrm.Caption
'00020     For intIdx = 0 To Forms.Count - 1
'00021         Set frm = Forms(intIdx)
'00022         If frm Is rfrm Then
'00023            strCaption = CStr(intIdx + 1) & ". " & strCaption
'00024         End If
'00025     Next intIdx
'00026     mfrm.Caption = strCaption
'00027 End Function
'00028
'00029 Public Function UnDock()
'00030     mfrm.TimerInterval = 0
'00031     mfrm.OnTimer = ""
'00032     Set mfrm = Nothing
'00033 End Function
'00034
'00035 Public Sub mtdClose()
'00036     mfrm.SetFocus
'00037     DoCmd.Close
'00038 End Sub
'00039
'00040 Public Sub mtdTestDurationReset(ByVal vintTestDuration As Integer)
'00041     mintTestDuration = vintTestDuration
'00042 End Sub
'00043
'00044 Private Sub mfrm_Timer()
'00045     Dim strMsg As String
'00046     mintTestDuration = mintTestDuration - 1
'00047     strMsg = ""
'00048     strMsg = strMsg & "Form closes inself in " & mintTestDuration & " seconds," & vbCrLf
'00049     strMsg = strMsg & "meantime you can click on label or rectangle " & vbCrLf
'00050     strMsg = strMsg & "border to see their DEEPs in effect or" & vbCrLf
'00051     strMsg = strMsg & "click [OK]" & vbCrLf & "to close test form..."
'00052     mfrm![lblMsg].Caption = strMsg
'00053     If mintTestDuration = 0 Then mtdClose
'00054 End Sub
'00055
'00056
'//EOM clsFormDEEP
'//SOM clsFormsRegistry
'00001 Option Compare Database
'00002 Option Explicit
'00003
'00004 Private mobjFormsRegistry As New clsObjectRegistry
'00005
'00006 Private Sub Class_Terminate()
'00007     Set mobjFormsRegistry = Nothing
'00008 End Sub
'00009
'00010 Public Function CheckIn(ByRef rfrm As Form, ByVal vvarFormId As Variant)
'00011     mobjFormsRegistry.CheckIn rfrm, vvarFormId
'00012 End Function
'00013
'00014 Public Function CheckOut(ByRef rfrm As Form, ByVal vvarFormId As Variant)
'00015     mobjFormsRegistry.CheckOut rfrm, vvarFormId
'00016 End Function
'00017
'00018 Public Property Get Item(ByVal vvarFormId As Variant) As Variant
'00019     Set Item = mobjFormsRegistry.Item(vvarFormId)
'00020 End Property
'00021
'//EOM clsFormsRegistry
'//SOM clsLastLblCtlInQueue
'00001 Option Compare Database
'00002 Option Explicit
'00003
'00004 Private WithEvents mctl As Label
'00005
'00006 Public Function Dock(ByRef rctl As Control)
'00007     Set mctl = rctl
'00008     mctl.Properties("OnClick") = "[Event procedure]"
'00009 End Function
'00010
'00011 Public Function UnDock()
'00012     mctl.Properties("OnClick") = ""
'00013     Set mctl = Nothing
'00014 End Function
'00015
'00016 Private Sub mctl_Click()
'00017     mctl.FontSize = 9
'00018     mctl.FontUnderline = Not (mctl.FontUnderline)
'00019 End Sub
'00020
'//EOM clsLastLblCtlInQueue
'//SOM clsLblCtlDEEP
'00001 Option Compare Database
'00002 Option Explicit
'00003
'00004 Private WithEvents mlbl As Label
'00005
'00006 Public Function Dock(ByRef rlbl As Label)
'00007     Set mlbl = rlbl
'00008     rlbl.OnClick = "[Event procedure]"
'00009 End Function
'00010
'00011 Public Function UnDock()
'00012     mlbl.OnClick = ""
'00013     Set mlbl = Nothing
'00014 End Function
'00015
'00016 Private Sub mlbl_Click()
'00017     mlbl.FontItalic = Not (mlbl.FontItalic)
'00018 End Sub
'00019
'//EOM clsLblCtlDEEP
'//SOM clsObjectRegistry
'00001 Option Compare Database
'00002 Option Explicit
'00003
'00004 Private mcolObjectRegistry As New Collection
'00005
'00006 Private Sub Class_Terminate()
'00007     Set mcolObjectRegistry = Nothing
'00008 End Sub
'00009
'00010 Public Function CheckIn(ByRef robj As Object, ByVal vvarObjId As Variant)
'00011     mcolObjectRegistry.Add robj, CStr(vvarObjId)
'00012 End Function
'00013
'00014 Public Function CheckOut(ByRef robj As Object, ByVal vvarObjId As Variant)
'00015     mcolObjectRegistry.Remove CStr(vvarObjId)
'00016 End Function
'00017
'00018 Public Property Get Item(ByVal vvarObjId As Variant) As Variant
'00019     Set Item = mcolObjectRegistry.Item(vvarObjId)
'00020 End Property
'00021
'//EOM clsObjectRegistry
'//SOM clsShpCtlDEEP
'00001 Option Compare Database
'00002 Option Explicit
'00003
'00004 Private WithEvents mshp As Rectangle
'00005
'00006 Public Function Dock(ByRef rshp As Rectangle)
'00007     Set mshp = rshp
'00008     rshp.OnClick = "[Event procedure]"
'00009 End Function
'00010
'00011 Public Function UnDock()
'00012     mshp.OnClick = ""
'00013     Set mshp = Nothing
'00014 End Function
'00015
'00016 Private Sub mshp_Click()
'00017    mshp.SpecialEffect = 5 - mshp.SpecialEffect
'00018 End Sub
'00019
'//EOM clsShpCtlDEEP
'//EOP


Copyright 1999-2008 by Shamil Salakhetdinov.  All rights reserved.