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!
- Students Click Here
*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. Students Click Here
|
Microsoft: Access Modules (VBA Coding) FAQ
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
|
|
|
|
Talk To Other Members