Writing Code to Manipulate Code


Question

I have a couple of applications which are being implemented modularly (develop, test, install one segment, then start the process over on another segment, etc.) Since I am not yet using a Framework :-(, I manually add resizing code to each of my forms. I'm looking for a utility function which would search the module in each form for a specific string (e.g., "adhTypeRect") to determine if resizing code exists for that form, and would inform me of forms where the string is not found.

Answer

Julie,

The functions in P.S. solve some of the tasks you need to solve - automatic patching of functions - in my case they substitute function mtdCallBack(...) in forms' modules with a new version and function vlmCallBack (...) in class modules with new version.

Feel free to adapt these functions for your needs,
HTH,
Shamil

P.S. The code:

Option Compare Database
Option Explicit

'*+
'
' Purpose:
'          - Replace functions named mtdCallback(...) of forms modules with the
'            function generated by ReplaceProc1(...).
'          - Replace functions named vlmCallback(...) of class modules named
'            cls<SomeName>ObjectInterface with the function generated by ReplaceProc2(...).
'
'*-
Public Function dasReplaceModProcs()

    Dim con As Container
    Dim doc As Document

    'For Each con In CodeDb().Containers
    For Each con In CurrentDb().Containers
      Select Case con.Name
      Case "Forms":
        For Each doc In con.Documents
          If Left(doc.Name, 1) <> "_" Then
           If Right(doc.Name, 6) <> "LookUp" Then
              ProcLineInfo doc.Name, "Form_" & doc.Name, "mtdCallBack"
              Debug.Print doc.Name & " processed."
           End If
          End If
        Next
      Case "Modules":
        For Each doc In con.Documents
          If Left(doc.Name, 1) <> "_" Then
           If Left(doc.Name, 3) = "cls" And InStr(1, doc.Name, "ObjectInterface") <> 0 Then
              ProcLineInfo "", doc.Name, "vlmCallBack"
              Debug.Print doc.Name & " processed."
           End If
          End If
        Next
      Case Else
      End Select
    Next
End Function

Private Function ProcLineInfo(strFormName As String, strModuleName As String, strProcName As String)
    Dim mdl As Module
    Dim lngStartLine As Long, lngBodyLine As Long
    Dim lngCount As Long, lngEndProc As Long

    ' Open specified Module object.
    If strFormName <> "" Then
       DoCmd.OpenForm strFormName, acDesign
    End If

    DoCmd.OpenModule strModuleName

    Dim lngCountOfLines As Long
    ' Return reference to Module object.
    Set mdl = Modules(strModuleName)
    lngCountOfLines = mdl.CountOfLines

    ' Count lines in procedure.
    On Error Resume Next
    lngCount = mdl.ProcCountLines(strProcName, vbext_pk_Proc)
    If Err <> 0 Then
       MsgBox "err = " & Err.Number & " - " & Err.Description, vbOKOnly
       Err.Clear
       On Error GoTo 0
       GoTo ProcLineInfo_Cont
    End If
    On Error GoTo 0
    ' Determine start line.
    lngStartLine = mdl.ProcStartLine(strProcName, vbext_pk_Proc)

    ' Determine body line.
    lngBodyLine = mdl.ProcBodyLine(strProcName, vbext_pk_Proc)
    Debug.Print

    ' Print all lines in procedure preceding body line.
    'Debug.Print "Lines preceding procedure " & strProcName & ": "
    'Debug.Print mdl.Lines(lngStartLine, lngBodyLine - lngStartLine)

    ' Determine line number of last line in procedure.
    lngEndProc = (lngBodyLine + lngCount - 1) - Abs(lngBodyLine - lngStartLine)

    ' Print all lines in body of procedure.

    'Debug.Print mdl.Lines(lngBodyLine, (lngEndProc - lngBodyLine) + 1)

    SendKeys "^{Home}"
    SendKeys "^{End}"
    DoEvents

    Dim l As Long
    For l = 1 To CInt(lngCountOfLines - lngStartLine)
      SendKeys "{Up}"
    Next

    DoEvents

    For l = lngStartLine To lngCountOfLines
       If mdl.Lines(l, 1) = "end function" Then
          'Debug.Print "Body lines: "
          'Debug.Print mdl.Lines(lngStartLine, l - lngStartLine + 1)
          'Debug.Print "Start 2 lines:"
          'Debug.Print mdl.Lines(lngStartLine, 2)
          'Debug.Print "End line:"
          'Debug.Print mdl.Lines(l, 1)

          If Left(mdl.Name, 3) = "cls" Then
             ReplaceProc2 mdl, lngStartLine, l - lngStartLine + 1
          Else
             ReplaceProc1 mdl, lngStartLine, l - lngStartLine + 1
          End If
         Exit For
       Else
          SendKeys "{Down}"
       End If
    Next l

ProcLineInfo_Cont:
    If MsgBox("Continue ?", vbQuestion + vbYesNo, "Code substitutor") = vbNo Then
       DoEvents
       End
    Else
       If strFormName <> "" Then
          DoCmd.Close acForm, strFormName, acSaveYes
       Else
          DoCmd.Close acModule, mdl.Name, acSaveYes
       End If
    End If
End Function


Private Function ReplaceProc1(ByRef rmdl As Module, _
                              ByVal vlngStartAt As Long, _
                              ByVal vlngCountOfLines As Long)
    Dim strText As String

    strText = vbCrLf
    strText = strText & "Public Function mtdCallBack(ParamArray avarRetValues() As Variant)" & vbCrLf
    strText = strText & "   On Error Resume Next" & vbCrLf
    strText = strText & "   Dim colArgs As New Collection" & vbCrLf
    strText = strText & "   Dim intIdx As Integer" & vbCrLf
    strText = strText & "" & vbCrLf
    strText = strText & "   If UBound(avarRetValues()) = -1 Then" & vbCrLf
    strText = strText & "       Set colArgs = Nothing" & vbCrLf
    strText = strText & "   Else" & vbCrLf
    strText = strText & "       For intIdx = 0 To UBound(avarRetValues())" & vbCrLf
    strText = strText & "           colArgs.Add avarRetValues(intIdx),CStr(intIdx + 1)" & vbCrLf
    strText = strText & "       Next intIdx" & vbCrLf
    strText = strText & "   End If" & vbCrLf
    strText = strText & "" & vbCrLf
    strText = strText & "   vlmFormCallBackProcess Me, colArgs" & vbCrLf
    strText = strText & "   Set colArgs = Null" & vbCrLf
    strText = strText & "End Function" & vbCrLf

    rmdl.DeleteLines vlngStartAt, vlngCountOfLines
    InsertLines rmdl, vlngStartAt, strText
End Function

Private Function ReplaceProc2(ByRef rmdl As Module, _
                              ByVal vlngStartAt As Long, _
                              ByVal vlngCountOfLines As Long)
    Dim strText As String

    strText = strText & "" & vbCrLf
    strText = strText & "Public Function vlmCallBack(ByRef robjCaller As Object, _" & vbCrLf
    strText = strText & "                            Optional ByVal vstrReturnOpName As String = ""ReturnLookUpValue"", _" & vbCrLf
    strText = strText & "                            Optional ByVal vstrReturnFromObjName As String = """", _" & vbCrLf
    strText = strText & "                            Optional ByVal vstrRetArgs As String = """")" & vbCrLf
    strText = strText & "       On Error Resume Next" & vbCrLf
    strText = strText & "" & vbCrLf
    strText = strText & "       Select Case vstrReturnOpName" & vbCrLf
    strText = strText & "       Case ""ReturnLookUpValue"",""ReturnSelectionList"", ""ReturnFocus"":" & vbCrLf
    strText = strText & "           robjCaller.mtdCallBack vstrReturnOpName,vstrReturnFromObjName, vstrRetArgs" & vbCrLf
    strText = strText & "       Case Else" & vbCrLf
    strText = strText & "           robjCaller.mtdCallBack vstrReturnOpName,vstrReturnFromObjName, vstrRetArgs" & vbCrLf
    strText = strText & "       End Select" & vbCrLf
    strText = strText & "       err.Clear" & vbCrLf
    strText = strText & "End Function" & vbCrLf

    rmdl.DeleteLines vlngStartAt, vlngCountOfLines
    InsertLines rmdl, vlngStartAt, strText
End Function

Private Function InsertLines(ByRef rmdl As Module, _
                             ByVal vlngInsertAt As Long, _
                             ByVal vstrText2Ins As String)
    rmdl.InsertLines vlngInsertAt, vstrText2Ins
End Function

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