INTELLIGENT WORK FORUMS
FOR COMPUTER PROFESSIONALS

Log In

Come Join Us!

Are you a
Computer / IT professional?
Join Tek-Tips Forums!
  • Talk With Other Members
  • Be Notified Of Responses
    To Your Posts
  • Keyword Search
  • One-Click Access To Your
    Favorite Forums
  • Automated Signatures
    On Your Posts
  • Best Of All, It's Free!

*Tek-Tips's functionality depends on members receiving e-mail. By joining you are opting in to receive e-mail.

Posting Guidelines

Promoting, selling, recruiting, coursework and thesis posting is forbidden.

Jobs

Misc

Extract information from macros by RoyVidar
Posted: 6 Apr 05 (Edited 10 Jun 05)

Of course you don't use any macros, except perhaps the AutoExec or AutoKeys... but then you inherit an undokumented monster containing lot's of macros. What do you do?

The following routine relies on an undocumented method of the Access Application object, SaveAsText, so be careful.

I'm using the Split, InStrRev and Replace functions, which don't exists in Access 97. To make it work in Access 97, you will need replacement functions. RickSpr has alredy created some good replacement functions, available in FAQ705-4342, which will need to be copied into a new module, in addition to the code in this faq. I needed to make some adjustments to the Split function, so that's an additional snippet at the bottom of the current code (rvsSplit - not needed for Access 2000+ versions).

To make this work, I've used some conditional compilation statements, which should ensure the correct version of the functions are used. Those can be removed, if only working with later versions (ensure you delete everything in the #Else clause)

The usage of Regular Expressions, should normally work on all computers with Internet Explorer 5.0 or later. It needs vbscript.dll. You should be able to get the latest version of the Window script somewhere on Microsofts site.

Note hovewer, that some companies have restrictions on scripts. In such case, this will not work.

Public Sub rvsGetMacros(ByVal v_strPath As String)
' royvidar
' created 2005-04-06
' altered 2005-06-10
' purpose:      get a list of all macros in the project
' parameters:   v_strPath - existing path where one wish
'               to place the results
'               note - all existing files in the directory
'               will be deleted
' output:       output.txt - contains macro actions
'               all macros as text files

' using late binding, no need to set any references
' - will probaby not work in an ADP

    Dim fs                  As Object
    Dim txtIn               As Object
    Dim txtOut              As Object
    Dim strPath             As String
    Dim fls                 As Object
    Dim fl                  As Object
    Dim re                  As Object
    Dim mc                  As Object
    Dim m                   As Object
    Dim doc                 As Object
    Dim db                  As Object
    Dim strLastMacro        As String
    Dim strText             As String
    Dim strOut              As String
    Dim lngcounter          As Long
    
    #If CBool(VBA6) Then
        Dim strMacro()      As String
        Dim strArgs()       As String
    #Else
        Dim strMacro
        Dim s1
        Dim s2
    #End If
    
    If Right$(v_strPath, 1) = "\" Then
        strPath = v_strPath
    Else
        strPath = v_strPath & "\"
    End If
    
    Const cstrOutput        As String = "output.txt"
    
    Set fs = CreateObject("scripting.filesystemobject")
    If fs.FolderExists(strPath) Then
        If MsgBox("This will delete ALL existing files in" & _
                vbNewLine & vbNewLine & vbTab & strPath & _
                vbNewLine & vbNewLine & "Proceed?", _
                vbExclamation + vbYesNo, "Warning!") = vbNo Then
            Set fs = Nothing
            Exit Sub
        End If
        Set fls = fs.GetFolder(strPath).Files
        For Each fl In fls
            fs.DeleteFile (fl.Path)
        Next fl
    Else
        MsgBox "wrong path...", vbExclamation, "cancelling..."
        Set fs = Nothing
        Exit Sub
    End If
    
    Set db = CurrentDb
    For Each doc In db.Containers("Scripts").Documents
        SaveAsText acMacro, doc.Name, strPath & "\" & doc.Name & ".txt"
    Next
    
    Set re = CreateObject("vbscript.regexp")
    With re
        .MultiLine = True
        .Global = True
        .IgnoreCase = True
    End With
    
    Set fls = fs.GetFolder(strPath).Files
    Set txtOut = fs.CreateTextFile(strPath & cstrOutput, True)
    
    For Each fl In fls
        If fl.Name <> cstrOutput Then
            Set txtIn = fs.OpenTextFile(strPath & fl.Name, 1) ' For reading
            
            strText = txtIn.ReadAll
            txtIn.Close
            Set txtIn = Nothing
            
            strLastMacro = "Macro name : " & fl.Name & vbNewLine & _
                    "Name" & vbTab & "Condition" & vbTab & "Action" & _
                    vbTab & vbTab & "Arguement" & vbNewLine & _
                    String(70, "_") & vbNewLine
            
            ' pattern to retrieve macros
            re.Pattern = "Begin(.|\n)*?End\s"
            Set mc = re.Execute(strText)
            For Each m In mc
                ' assigning macro to macro array - macroname,
                ' action and conditions will be in first
                ' array element
                #If CBool(VBA6) Then
                    strMacro = Split(m.Value, "Argument =")
                    strArgs = Split(strMacro(0), vbCrLf)
                    For lngcounter = 0 To UBound(strArgs)
                        If (InStr(strArgs(lngcounter), "Macroname") > 0) Then
                            strOut = strOut & _
                                Split(strArgs(lngcounter), "=")(1) & vbNewLine
                        End If
                        If (InStr(strArgs(lngcounter), "Condition") > 0) Then
                            strOut = strOut & vbTab & _
                                Split(strArgs(lngcounter), "=")(1) & vbNewLine
                        End If
                        If (InStr(strArgs(lngcounter), "Action") > 0) Then
                            strOut = strOut & vbTab & vbTab & vbTab & _
                                Split(strArgs(lngcounter), "=")(1) & vbNewLine
                        End If
                    Next lngcounter
                #Else
                    strMacro = rvsSplit(m.Value, "Argument =")
                    s1 = rvsSplit(strMacro(0), vbCrLf)
                    For lngcounter = 0 To UBound(s1)
                        If (InStr(s1(lngcounter), "Macroname") > 0) Then
                            strOut = strOut & _
                                rvsSplit(s1(lngcounter), "=")(1) & vbNewLine
                        End If
                        If (InStr(s1(lngcounter), "Condition") > 0) Then
                            strOut = strOut & vbTab & _
                                rvsSplit(s1(lngcounter), "=")(1) & vbNewLine
                        End If
                        If (InStr(s1(lngcounter), "Action") > 0) Then
                            strOut = strOut & vbTab & vbTab & vbTab & _
                                rvsSplit(s1(lngcounter), "=")(1) & vbNewLine
                        End If
                    Next lngcounter
                #End If
                            
                ' To proceed, just testing if there's an action arguement
                ' then it contains more...
                If (InStr(strMacro(0), "Action") > 0) Then
                    For lngcounter = 1 To UBound(strMacro)
                        strOut = strOut & vbTab & vbTab & vbTab & vbTab & vbTab & _
                            Replace(Trim$(strMacro(lngcounter)), _
                            vbNewLine, vbNullString) & vbNewLine
                    Next lngcounter
                End If
                
                ' writing output
                If Len(strOut) > 0 Then
                    If InStr(strOut, "End") > 0 Then
                        txtOut.WriteLine strLastMacro & _
                            Mid$(strOut, 1, InStrRev(strOut, "End") - 1) & _
                            vbNewLine
                    Else
                        txtOut.WriteLine strLastMacro & strOut & vbNewLine
                    End If
                    ' cleaning a little before next run
                    strLastMacro = vbNullString
                    strOut = vbNullString
                 End If
            Next m
        End If
    Next fl
    txtOut.Close
    
    ' turning off the lights when leaving...
    Set db = Nothing
    Set doc = Nothing
    Set fl = Nothing
    Set fls = Nothing
    Set txtIn = Nothing
    Set txtOut = Nothing
    Set fs = Nothing
    Set m = Nothing
    Set mc = Nothing
    Set re = Nothing
End Sub

Public Function rvsSplit(ByVal v_strInString As String, _
                        Optional ByVal v_strDelimiter As String = "|") As Variant
' royvidar
' created 2005-03-09
' purpose:      split a string into a variant array for processing
'               In this setting, I relax a little on testing, as I'll
'               only pass string variables. Use variant and add a test
'               with the IsMissing function to use in other context
' parameters:
'               v_strInString - string containing text with delimiter
'                   i e - string to be split
'               v_strDelimiter - the delimiter to use in the split
' returns:      variant array

    Dim lngCounter          As Long     ' count number of delimiters to redim array
    Dim lngStart            As Long     ' start position of string to extract
    Dim lngStop             As Long     ' end postition of string to extract
    Dim varResult()                     ' variant array assigned as return value
    
On Error GoTo rvsSplit_Err
    
    If Len(v_strInString) > 0 Then
        lngStart = 1
        Do
            lngStop = InStr(lngStart, v_strInString, v_strDelimiter)
            If lngStop = 0 Then Exit Do
            ReDim Preserve varResult(lngCounter)
            varResult(lngCounter) = _
                      Mid$(v_strInString, lngStart, lngStop - lngStart)
            lngCounter = lngCounter + 1
            lngStart = lngStop + Len(v_strDelimiter)
        Loop
        ReDim Preserve varResult(lngCounter)
        varResult(lngCounter) = Mid$(v_strInString, lngStart)
    Else
        rvsSplit = Array()
    End If
    rvsSplit = varResult
    
rvsSplit_Exit:
    Exit Function
rvsSplit_Err:
    rvsSplit = vbNullString
    Resume rvsSplit_Exit
End Function


There's also a "comment" property that can be extracted. Due to my laziness, I didn't bother extracting that.

Thanks to JerryKlmns, who found another bug.

Next question, is this exercise really necessary, one can use the Documenter in Tools | Analyze, select the Macro tab, then the options button... and get even more information (arguement name too), but I leave that up to you to decide.

If you have any comments, suggestions to make it better, don't hesitate to contact me. Happy coding!

Back to Microsoft: Access Modules (VBA Coding) FAQ Index
Back to Microsoft: Access Modules (VBA Coding) Forum

My Archive

Resources

Close Box

Join Tek-Tips® Today!

Join your peers on the Internet's largest technical computer professional community.
It's easy to join and it's free.

Here's Why Members Love Tek-Tips Forums:

Register now while it's still free!

Already a member? Close this window and log in.

Join Us             Close