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. 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 |
|
|
|