I answered a question somewhere else, on how to get information on specific macro actions (sendobject), for someone who'd inherited a "monster-macro" db. Just had a little go at cleaning it up a little, to be a bit more general.
This is in no way fully tested, contains no errorchecking, but tasks like this isn't usually used in production, but as a "one timer", so hopefully it'll do.
It relies on some undocumented features (.SaveAsText), so use with care.
I'm using the Split and Replace functions, which doesn't exist in a97, so I've included som conditional compilation statements to allow for compilation on both a97 and later versions.
Note - I've used the Replace function from RickSpr faq faq705-4342, which you'll need also. Except I couldn't make his Split function work, so a version, at least working on my setup (rvsSplit), will also be needed in a97.
Also note - if there are some restrictions on the scripting libraries, it will fail.
There's a small bug, it cut's of the text when a macro has an action without any arguements (as in Beep, Maximize...)
[tt]Public Sub rvsGetMacros(ByVal v_strPath As String)
' royvidar
' created 2005-04-06
' 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
' - due to usage of the Split function, 2000+ versions
' unless "replacement split" functions can be used
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
#Else
Dim strMacro
Dim s1
Dim s2
#End If
If Right$(v_strPath, 1) = "\" Then
strPath = v_strPath
Else
strPath = v_strPath & "\"
End If
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 & "output.txt", True)
For Each fl In fls
Set txtIn = fs.OpenTextFile(strPath & fl.Name, 1) ' For reading
strText = txtIn.ReadAll
txtIn.Close
Set txtIn = Nothing
' pattern to retrieve macros
re.Pattern = "Begin(.|\n)*?End\s"
strLastMacro = "Name of macro (db window/filename): " & _
fl.Name & vbNewLine
Set mc = re.Execute(strText)
For Each m In mc
' assigning macro to macro array
#If CBool(VBA6) Then
strMacro = Split(m.Value, "Argument =")
#Else
strMacro = rvsSplit(m.Value, "Argument =")
#End If
' doing some rather nasty splits to get at the info
' first - if there's a macro name in the Macroname
' column of the macro
If (InStr(strMacro(0), "Macroname") > 0) Then
#If CBool(VBA6) Then
strOut = "Macro Name (from column within macro): " & _
Split(Split(strMacro(0), "Action")(0), "=")(1)
#Else
strOut = "Macro Name (from column within macro): " & _
rvsSplit(rvsSplit(strMacro(0), "Action")(0), "=")(1)
#End If
End If
' then getting the macro action (SendObject, MsgBox...)
' then looping the arguements
If (InStr(strMacro(0), "Action") > 0) Then
#If CBool(VBA6) Then
strOut = strOut & Replace(Split(Split(strMacro(0), _
"Action")(1), "=")(1), vbNewLine, vbNullString)
#Else
s1 = rvsSplit(strMacro(0), "Action")
s2 = rvsSplit(s1(1), "=")
strOut = strOut & _
Replace(CStr(s2(1)), vbCrLf, vbNullString)
#End If
For lngCounter = 1 To UBound(strMacro)
strOut = strOut & _
Replace(Trim$(strMacro(lngCounter)), _
vbNewLine, vbNullString) & ", "
Next lngCounter
End If
' writing output
If Len(strOut) > 0 Then
txtOut.WriteLine strLastMacro & _
Left$(strOut, Len(strOut) - 6) & vbNewLine
' cleaning a little before next run
strLastMacro = vbNullString
strOut = vbNullString
End If
Next m
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 of delimiters - redim array
Dim lngStart As Long ' start position of string
Dim lngStop As Long ' end postition of string
Dim varResult() ' variant array
On Error GoTo SaxoSplit_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
SaxoSplit_Exit:
Exit Function
SaxoSplit_Err:
rvsSplit = ""
Resume SaxoSplit_Exit
End Function[/tt]
Roy-Vidar
