PDA

View Full Version : Solved: Get functions list in Worksheet



anandbohra
10-14-2007, 11:02 PM
Hi all
I am trying to get list of all Custom functions with their syntax in the excel sheet.
because some of you are even facing the same problem that many a times we put the custom function in our workbook & get it protected but as we are not familiar with them we have to open the protected file & get the same through VBA code or go to function wizard to get the same.
is there is any other method specially VBA which runs a loop in all open workbook & get the function name with their syntax in activesheet.

say function = myfunction (tval as variant, testrange as range) as variant

like wise.
Hope u got my query.

matthewspatrick
10-15-2007, 08:34 AM
This appears to work. It requires a reference to VBA Extensibility.





Option Explicit
Option Compare Text


Sub GrabFuncs()

Dim wb As Workbook
Dim vbp As VBProject
Dim vbc As VBComponent
Dim cm As CodeModule
Dim arr As Variant
Dim ws As Worksheet
Dim Counter As Long
Dim Funcs As Long


With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With


Set ws = Worksheets.Add
ws.[a1:d1] = Array("Workbook", "Function", "Arguments", "Return Type")


For Each wb In Workbooks
Set vbp = wb.VBProject
For Each vbc In vbp.VBComponents
Set cm = vbc.CodeModule
arr = RegExpFind(cm.Lines(1, cm.CountOfLines), "Function \w+\([\w\s,]+\)([\w\s]+As[\w\s]+[a-z]+)?", , False)
If IsArray(arr) Then
For Counter = 0 To UBound(arr)
arr(Counter) = RegExpReplace(CStr(arr(Counter)), "\s+", " ")
Funcs = Funcs + 1
ws.Cells(Funcs + 1, 1) = wb.Name
ws.Cells(Funcs + 1, 2) = Split(Split(arr(Counter), "(")(0), "Function ")(1)
ws.Cells(Funcs + 1, 3) = Split(Split(arr(Counter), "(")(1), ")")(0)
If Right(arr(Counter), 1) <> ")" Then
ws.Cells(Funcs + 1, 4) = Split(Split(arr(Counter), ")")(1), "As ")(1)
Else
ws.Cells(Funcs + 1, 4) = "Variant"
End If
Next
End If
Next
Next


If Funcs = 0 Then
ws.Delete
MsgBox "No user defined functions found in open workbooks", vbInformation
Else
MsgBox "Found " & Funcs & " user defined functions", vbInformation
ws.Columns.AutoFit
End If


With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With

End Sub


Function RegExpFind(LookIn As String, PatternStr As String, Optional Pos, _
Optional MatchCase As Boolean = True)
' This function uses Regular Expressions to parse a string (LookIn), and return matches to a
' pattern (PatternStr). Use Pos to indicate which match you want:
' Pos omitted : function returns a zero-based array of all matches
' Pos = 0 : the last match
' Pos = 1 : the first match
' Pos = 2 : the second match
' Pos = <positive integer> : the Nth match
' If Pos is greater than the number of matches, is negative, or is non-numeric, the function
' returns an empty string. If no match is found, the function returns an empty string


' If MatchCase is omitted or True (default for RegExp) then the Pattern must match case (and
' thus you may have to use [a-zA-Z] instead of just [a-z] or [A-Z]).


' If you use this function in Excel, you can use range references for any of the arguments.
' If you use this in Excel and return the full array, make sure to set up the formula as an
' array formula. If you need the array formula to go down a column, use TRANSPOSE()


Dim RegX As Object
Dim TheMatches As Object
Dim Answer() As String
Dim Counter As Long


' Evaluate Pos. If it is there, it must be numeric and converted to Long
If Not IsMissing(Pos) Then
If Not IsNumeric(Pos) Then
RegExpFind = ""
Exit Function
Else
Pos = CLng(Pos)
End If
End If


' Create instance of RegExp object
Set RegX = CreateObject("VBScript.RegExp")
With RegX
.Pattern = PatternStr
.Global = True
.IgnoreCase = Not MatchCase
End With


' Test to see if there are any matches
If RegX.test(LookIn) Then


' Run RegExp to get the matches, which are returned as a zero-based collection
Set TheMatches = RegX.Execute(LookIn)


' If Pos is missing, user wants array of all matches. Build it and assign it as the
' function's return value
If IsMissing(Pos) Then
ReDim Answer(0 To TheMatches.Count - 1) As String
For Counter = 0 To UBound(Answer)
Answer(Counter) = TheMatches(Counter)
Next
RegExpFind = Answer


' User wanted the Nth match (or last match, if Pos = 0). Get the Nth value, if possible
Else
Select Case Pos
Case 0 ' Last match
RegExpFind = TheMatches(TheMatches.Count - 1)
Case 1 To TheMatches.Count ' Nth match
RegExpFind = TheMatches(Pos - 1)
Case Else ' Invalid item number
RegExpFind = ""
End Select
End If


' If there are no matches, return empty string
Else
RegExpFind = ""
End If


' Release object variables
Set RegX = Nothing
Set TheMatches = Nothing


End Function


Function RegExpReplace(LookIn As String, PatternStr As String, Optional ReplaceWith As String = "", _
Optional ReplaceAll As Boolean = True, Optional MatchCase As Boolean = True)
' This function uses Regular Expressions to parse a string, and replace parts of the string
' matching the specified pattern with another string. The optional argument ReplaceAll controls
' whether all instances of the matched string are replaced (True) or just the first instance (False)


' By default, RegExp is case-sensitive in pattern-matching. To keep this, omit MatchCase or
' set it to True


' If you use this function from Excel, you may substitute range references for all the arguments


Dim RegX As Object


Set RegX = CreateObject("VBScript.RegExp")
With RegX
.Pattern = PatternStr
.Global = ReplaceAll
.IgnoreCase = Not MatchCase
End With


RegExpReplace = RegX.Replace(LookIn, ReplaceWith)


Set RegX = Nothing


End Function

matthewspatrick
10-15-2007, 08:41 AM
Trying the code again, because the editor mangled my indenting...



Option Explicit
Option Compare Text
Sub GrabFuncs()
Dim wb As Workbook
Dim vbp As VBProject
Dim vbc As VBComponent
Dim cm As CodeModule
Dim arr As Variant
Dim ws As Worksheet
Dim Counter As Long
Dim Funcs As Long

With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With

Set ws = Worksheets.Add
ws.[a1:d1] = Array("Workbook", "Function", "Arguments", "Return Type")

For Each wb In Workbooks
Set vbp = wb.VBProject
For Each vbc In vbp.VBComponents
Set cm = vbc.CodeModule
arr = RegExpFind(cm.Lines(1, cm.CountOfLines), "Function \w+\([\w\s,]+\)([\w\s]+As[\w\s]+[a-z]+)?", , False)
If IsArray(arr) Then
For Counter = 0 To UBound(arr)
arr(Counter) = RegExpReplace(CStr(arr(Counter)), "\s+", " ")
Funcs = Funcs + 1
ws.Cells(Funcs + 1, 1) = wb.Name
ws.Cells(Funcs + 1, 2) = Split(Split(arr(Counter), "(")(0), "Function ")(1)
ws.Cells(Funcs + 1, 3) = Split(Split(arr(Counter), "(")(1), ")")(0)
If Right(arr(Counter), 1) <> ")" Then
ws.Cells(Funcs + 1, 4) = Split(Split(arr(Counter), ")")(1), "As ")(1)
Else
ws.Cells(Funcs + 1, 4) = "Variant"
End If
Next
End If
Next
Next

If Funcs = 0 Then
ws.Delete
MsgBox "No user defined functions found in open workbooks", vbInformation
Else
MsgBox "Found " & Funcs & " user defined functions", vbInformation
ws.Columns.AutoFit
End If

With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub

Function RegExpReplace(LookIn As String, PatternStr As String, Optional ReplaceWith As String = "", _
Optional ReplaceAll As Boolean = True, Optional MatchCase As Boolean = True)
' This function uses Regular Expressions to parse a string, and replace parts of the string
' matching the specified pattern with another string. The optional argument ReplaceAll controls
' whether all instances of the matched string are replaced (True) or just the first instance (False)

' By default, RegExp is case-sensitive in pattern-matching. To keep this, omit MatchCase or
' set it to True

' If you use this function from Excel, you may substitute range references for all the arguments

Dim RegX As Object

Set RegX = CreateObject("VBScript.RegExp")
With RegX
.Pattern = PatternStr
.Global = ReplaceAll
.IgnoreCase = Not MatchCase
End With

RegExpReplace = RegX.Replace(LookIn, ReplaceWith)

Set RegX = Nothing

End Function

Function RegExpFind(LookIn As String, PatternStr As String, Optional Pos, _
Optional MatchCase As Boolean = True)
' This function uses Regular Expressions to parse a string (LookIn), and return matches to a
' pattern (PatternStr). Use Pos to indicate which match you want:
' Pos omitted : function returns a zero-based array of all matches
' Pos = 0 : the last match
' Pos = 1 : the first match
' Pos = 2 : the second match
' Pos = <positive integer> : the Nth match
' If Pos is greater than the number of matches, is negative, or is non-numeric, the function
' returns an empty string. If no match is found, the function returns an empty string

' If MatchCase is omitted or True (default for RegExp) then the Pattern must match case (and
' thus you may have to use [a-zA-Z] instead of just [a-z] or [A-Z]).

' If you use this function in Excel, you can use range references for any of the arguments.
' If you use this in Excel and return the full array, make sure to set up the formula as an
' array formula. If you need the array formula to go down a column, use TRANSPOSE()

Dim RegX As Object
Dim TheMatches As Object
Dim Answer() As String
Dim Counter As Long

' Evaluate Pos. If it is there, it must be numeric and converted to Long
If Not IsMissing(Pos) Then
If Not IsNumeric(Pos) Then
RegExpFind = ""
Exit Function
Else
Pos = CLng(Pos)
End If
End If

' Create instance of RegExp object
Set RegX = CreateObject("VBScript.RegExp")
With RegX
.Pattern = PatternStr
.Global = True
.IgnoreCase = Not MatchCase
End With

' Test to see if there are any matches
If RegX.test(LookIn) Then

' Run RegExp to get the matches, which are returned as a zero-based collection
Set TheMatches = RegX.Execute(LookIn)

' If Pos is missing, user wants array of all matches. Build it and assign it as the
' function's return value
If IsMissing(Pos) Then
ReDim Answer(0 To TheMatches.Count - 1) As String
For Counter = 0 To UBound(Answer)
Answer(Counter) = TheMatches(Counter)
Next
RegExpFind = Answer

' User wanted the Nth match (or last match, if Pos = 0). Get the Nth value, if possible
Else
Select Case Pos
Case 0 ' Last match
RegExpFind = TheMatches(TheMatches.Count - 1)
Case 1 To TheMatches.Count ' Nth match
RegExpFind = TheMatches(Pos - 1)
Case Else ' Invalid item number
RegExpFind = ""
End Select
End If

' If there are no matches, return empty string
Else
RegExpFind = ""
End If

' Release object variables
Set RegX = Nothing
Set TheMatches = Nothing

End Function

anandbohra
10-15-2007, 09:44 PM
Thanks matthewspatrick
but code give error in this line
error message is
"Invalid Procedure call or argumen"

arr = RegExpFind(cm.Lines(1, cm.CountOfLines), "Function \w+\([\w\s,]+\)([\w\s]+As[\w\s]+[a-z]+)?", , False)


this error comes while extracting 3rd function
means it extracts first 2 functions in the manner I want

& one more thing can u alpter procedure to leave a VBAproject if it is password protected.

matthewspatrick
10-16-2007, 05:13 AM
I suspect you're doing something wrong, as it tests out just fine for me.

This revised code does a better job with the arguments and tests for locked projects.





Option Explicit
Option Compare Text
Sub GrabFuncs()
Dim wb As Workbook
Dim vbp As VBProject
Dim vbc As VBComponent
Dim cm As CodeModule
Dim arr As Variant
Dim ws As Worksheet
Dim Counter As Long
Dim Funcs As Long

With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With

Set ws = Worksheets.Add
ws.[a1:d1] = Array("Workbook", "Function", "Arguments", "Return Type")

For Each wb In Workbooks
Set vbp = wb.VBProject
For Each vbc In vbp.VBComponents
On Error Resume Next
Set cm = vbc.CodeModule
If Err <> 0 Then
Err.Clear
MsgBox wb.Name & " has its VBProject locked; no info available", vbInformation, "No soup for you!"
GoTo GrabNextWorkbook
Else
arr = RegExpFind(cm.Lines(1, cm.CountOfLines), "Function \w+\([\w\s,]+\)([\w\s]+As[\w\s]+[a-z]+)?", , False)
If IsArray(arr) Then
For Counter = 0 To UBound(arr)
arr(Counter) = RegExpReplace(CStr(arr(Counter)), "[_\s]+", " ")
Funcs = Funcs + 1
ws.Cells(Funcs + 1, 1) = wb.Name
ws.Cells(Funcs + 1, 2) = Split(Split(arr(Counter), "(")(0), "Function ")(1)
ws.Cells(Funcs + 1, 3) = Split(Split(arr(Counter), "(")(1), ")")(0)
If Right(arr(Counter), 1) <> ")" Then
ws.Cells(Funcs + 1, 4) = Split(Split(arr(Counter), ")")(1), "As ")(1)
Else
ws.Cells(Funcs + 1, 4) = "Variant"
End If
Next
End If
End If
Next
GrabNextWorkbook:
Next

If Funcs = 0 Then
ws.Delete
MsgBox "No user defined functions found in open workbooks", vbInformation
Else
MsgBox "Found " & Funcs & " user defined functions", vbInformation
ws.Columns.AutoFit
End If

With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub

Function RegExpReplace(LookIn As String, PatternStr As String, Optional ReplaceWith As String = "", _
Optional ReplaceAll As Boolean = True, Optional MatchCase As Boolean = True)
' This function uses Regular Expressions to parse a string, and replace parts of the string
' matching the specified pattern with another string. The optional argument ReplaceAll controls
' whether all instances of the matched string are replaced (True) or just the first instance (False)

' By default, RegExp is case-sensitive in pattern-matching. To keep this, omit MatchCase or
' set it to True

' If you use this function from Excel, you may substitute range references for all the arguments

Dim RegX As Object

Set RegX = CreateObject("VBScript.RegExp")
With RegX
.Pattern = PatternStr
.Global = ReplaceAll
.IgnoreCase = Not MatchCase
End With

RegExpReplace = RegX.Replace(LookIn, ReplaceWith)

Set RegX = Nothing

End Function

Function RegExpFind(LookIn As String, PatternStr As String, Optional Pos, _
Optional MatchCase As Boolean = True)
' This function uses Regular Expressions to parse a string (LookIn), and return matches to a
' pattern (PatternStr). Use Pos to indicate which match you want:
' Pos omitted : function returns a zero-based array of all matches
' Pos = 0 : the last match
' Pos = 1 : the first match
' Pos = 2 : the second match
' Pos = <positive integer> : the Nth match
' If Pos is greater than the number of matches, is negative, or is non-numeric, the function
' returns an empty string. If no match is found, the function returns an empty string

' If MatchCase is omitted or True (default for RegExp) then the Pattern must match case (and
' thus you may have to use [a-zA-Z] instead of just [a-z] or [A-Z]).

' If you use this function in Excel, you can use range references for any of the arguments.
' If you use this in Excel and return the full array, make sure to set up the formula as an
' array formula. If you need the array formula to go down a column, use TRANSPOSE()

Dim RegX As Object
Dim TheMatches As Object
Dim Answer() As String
Dim Counter As Long

' Evaluate Pos. If it is there, it must be numeric and converted to Long
If Not IsMissing(Pos) Then
If Not IsNumeric(Pos) Then
RegExpFind = ""
Exit Function
Else
Pos = CLng(Pos)
End If
End If

' Create instance of RegExp object
Set RegX = CreateObject("VBScript.RegExp")
With RegX
.Pattern = PatternStr
.Global = True
.IgnoreCase = Not MatchCase
End With

' Test to see if there are any matches
If RegX.test(LookIn) Then

' Run RegExp to get the matches, which are returned as a zero-based collection
Set TheMatches = RegX.Execute(LookIn)

' If Pos is missing, user wants array of all matches. Build it and assign it as the
' function's return value
If IsMissing(Pos) Then
ReDim Answer(0 To TheMatches.Count - 1) As String
For Counter = 0 To UBound(Answer)
Answer(Counter) = TheMatches(Counter)
Next
RegExpFind = Answer

' User wanted the Nth match (or last match, if Pos = 0). Get the Nth value, if possible
Else
Select Case Pos
Case 0 ' Last match
RegExpFind = TheMatches(TheMatches.Count - 1)
Case 1 To TheMatches.Count ' Nth match
RegExpFind = TheMatches(Pos - 1)
Case Else ' Invalid item number
RegExpFind = ""
End Select
End If

' If there are no matches, return empty string
Else
RegExpFind = ""
End If

' Release object variables
Set RegX = Nothing
Set TheMatches = Nothing

End Function

anandbohra
10-16-2007, 10:22 PM
Thanks for the reply
got the solution

:friends: