求写代码找出所有函数和子程序

oob111

e:\a  下有若干工作薄，每个工作薄有若干模块，有的模块里包含有函数Function和子程序sub,
希望找出这些模块里的函数和子程序，或干脆直接把它们连同包含本函数或子程序的模块的代码append到e:\b\函数和子程序.txt里，谢谢了。

bbwsj

这个功能我也想要，最好能把必要的数据源也复制在一起
等高手

oob111

香川群子

bbwsj 发表于 2014-2-5 16:42
这个功能我也想要，最好能把必要的数据源也复制在一起
等高手

附件看6楼吧

1. Sub ModuleCodeCopy() 'by kagawa 2014/02/06
   
2.    
   
3.     With Application.FileDialog(msoFileDialogFolderPicker)
   
4.         If .Show Then myPath = .SelectedItems(1) Else Exit Sub
   
5.     End With
   
6.    
   
7.     Open ActiveWorkbook.Path & "" & Replace(Mid(myPath, 4), "", "_") & "_VBACode.txt" For Output As #1
   
8.     Print #1, myPath; vbCrLf
   
9.    
   
10.     Application.ScreenUpdating = False
    
11.     Application.DisplayAlerts = False
    
12.     myFile = Dir(myPath & "\*.xls")
    
13.     Do
    
14.         On Error Resume Next
    
15.         With Workbooks.Open(myFile)
    
16.             ModuleCnt = 0
    
17.             Print #1, "  "; vbCrLf; String(20, "="); vbCrLf; myFile; vbCrLf; "  "
    
18.             For Each vbc In .VBProject.VBComponents
    
19.                 With vbc.CodeModule
    
20.                     If .CountOfLines Then Print #1, " "; vbCrLf; String(10, "-"); .Name; String(10, "-"); vbCrLf; .Lines(1, .CountOfLines): ModuleCnt = ModuleCnt + 1
    
21.                 End With
    
22.             Next
    
23.             If ModuleCnt Then Print #1, vbCrLf; " "; "Get "; ModuleCnt; " Modules" Else Print #1, "No ModuleCode Exist"
    
24.         End With
    
25.         Windows(myFile).Close False
    
26.         myFile = Dir
    
27.         FileCount = FileCount + 1
    
28.     Loop Until myFile = ""
    
29.     Application.ScreenUpdating = True
    
30.    
    
31.     Print #1, vbCrLf; String(20, "="); vbCrLf; "  "; FileCount; " Files Checked"
    
32.     Close #1
    
33.    
    
34.     MsgBox FileCount & " Files Checked !"
    
35. End Sub

复制代码

香川群子

按楼主要求，仅仅提取Function代码：

1. 
   
2. '需引用 Microsoft Visual Basic For Application Extensibility 5.3
   
3. Sub FuncCodeCopy() 'by kagawa 2014/02/06
   
4.    
   
5.     With Application.FileDialog(msoFileDialogFolderPicker)
   
6.         If .Show Then myPath = .SelectedItems(1) Else Exit Sub
   
7.     End With
   
8.    
   
9.     Open ActiveWorkbook.Path & "" & Replace(Mid(myPath, 4), "", "_") & "_VBAFuncCode.txt" For Output As #1
   
10.     Print #1, myPath; vbCrLf
    
11.    
    
12.     Application.ScreenUpdating = False
    
13.     Application.DisplayAlerts = False
    
14.     myFile = Dir(myPath & "\*.xls")
    
15.     Do
    
16.         On Error Resume Next
    
17.         With Workbooks.Open(myFile)
    
18.             FileFuncCnt = 0
    
19.             Print #1, "  "; vbCrLf; String(20, "="); vbCrLf; myFile; vbCrLf; "  "
    
20.             For Each vbc In .VBProject.VBComponents
    
21.                 With vbc.CodeModule
    
22.                     FuncCnt = 0
    
23.                     If .CountOfLines Then
    
24.                         For i = 1 To .CountOfLines
    
25.                             myStr = .Lines(i, 1)
    
26.                             If myStr Like "Function *" Or myStr Like "* Function *" Then flag = True: FuncCnt = FuncCnt + 1: If FuncCnt = 1 Then Print #1, " "; vbCrLf; String(10, "-"); .Name; String(10, "-"); vbCrLf Else Print #1, " "; vbCrLf
    
27.                             If myStr Like "*End Function*" Then flag = False: Print #1, myStr; vbCrLf
    
28.                             If flag Then Print #1, myStr
    
29.                         Next
    
30.                     End If
    
31.                     If FuncCnt Then Print #1, vbCrLf; " "; "Get "; FuncCnt; " Functions in Module ["; .Name; "]"
    
32.                     FileFuncCnt = FileFuncCnt + FuncCnt
    
33.                 End With
    
34.             Next
    
35.             If FileFuncCnt Then Print #1, vbCrLf; " "; "Get total "; FileFuncCnt; " Functions in File <<"; myFile; ">>" Else Print #1, "No FunctionCode Exist"
    
36.         End With
    
37.         Windows(myFile).Close False
    
38.         myFile = Dir
    
39.         FileCount = FileCount + 1
    
40.     Loop Until myFile = ""
    
41.     Application.ScreenUpdating = True
    
42.    
    
43.     Print #1, vbCrLf; String(20, "="); vbCrLf; "  "; FileCount; " Files Checked"
    
44.     Close #1
    
45.     MsgBox FileCount & " Files Checked !"
    
46. End Sub
    

复制代码

代码有更新，附件看6楼

香川群子

好了，最后的代码，专门抽取被调用的Sub子过程的代码的程序：

1. Sub SubCodeCopy() 'by kagawa 2014/02/06
   
2.    
   
3.     With Application.FileDialog(msoFileDialogFolderPicker)
   
4.         If .Show Then myPath = .SelectedItems(1) Else Exit Sub
   
5.     End With
   
6.    
   
7.     Open ActiveWorkbook.Path & "" & Replace(Mid(myPath, 4), "", "_") & "_VBASubCode.txt" For Output As #1
   
8.     Print #1, myPath; vbCrLf
   
9.    
   
10.     Application.ScreenUpdating = False
    
11.     Application.DisplayAlerts = False
    
12.     myFile = Dir(myPath & "\*.xls")
    
13.     Do
    
14.         On Error Resume Next
    
15.         With Workbooks.Open(myFile)
    
16.             FileSubCnt = 0
    
17.             Print #1, "  "; vbCrLf; String(20, "="); vbCrLf; myFile; vbCrLf; "  "
    
18.             For Each vbc In .VBProject.VBComponents
    
19.                 With vbc.CodeModule
    
20.                     SubCnt = 0
    
21.                     If .CountOfLines Then
    
22.                         mySubName = ""
    
23.                         For i = 1 To .CountOfLines
    
24.                             myStr = .Lines(i, 1)
    
25.                             If myStr Like "Sub *" Or myStr Like " Sub *" Then
    
26.                                 myStr = Mid(myStr, InStr(myStr, "Sub ") + 4)
    
27.                                 myStr = Left(myStr, InStr(myStr, "(") - 1)
    
28.                                 mySubName = mySubName & "|" & myStr
    
29.                             End If
    
30.                         Next
    
31.                         
    
32.                         If mySubName <> "" Then
    
33.                             mySub = Split(mySubName, "|")
    
34.                             mySubName = "|"
    
35.                             For j = 1 To UBound(mySub)
    
36.                                 For i = 1 To .CountOfLines
    
37.                                     myStr = Trim(.Lines(i, 1))
    
38.                                     If myStr = mySub(j) Or myStr Like mySub(j) & " ,*" Or myStr = "Call " & mySub(j) Or myStr Like "Call " & mySub(j) & "(*" Then
    
39.                                         If InStr(mySubName, "|" & mySub(j) & "|") = 0 Then mySubName = mySubName & mySub(j) & "|"
    
40.                                     End If
    
41.                                 Next
    
42.                             Next
    
43.                            
    
44.                             If mySubName <> "|" Then
    
45.                                 mySub = Split(mySubName, "|")
    
46.                                 Print #1, " "; vbCrLf; String(10, "-"); .Name; String(10, "-"); vbCrLf
    
47.                                 For j = 1 To UBound(mySub) - 1
    
48.                                     For i = 1 To .CountOfLines
    
49.                                         myStr = .Lines(i, 1)
    
50.                                         If myStr Like "*Sub " & mySub(j) & "*" Then flag = True: Print #1, " "; vbCrLf: SubCnt = SubCnt + 1
    
51.                                         If flag And myStr Like "*End Sub*" Then flag = False: Print #1, myStr; vbCrLf
    
52.                                         If flag Then Print #1, myStr
    
53.                                     Next
    
54.                                 Next
    
55.                             End If
    
56.                         End If
    
57.                     End If
    
58.                     If SubCnt Then Print #1, vbCrLf; " "; "Get "; SubCnt; " SubCodes in Module ["; .Name; "]"
    
59.                     FileSubCnt = FileSubCnt + SubCnt
    
60.                 End With
    
61.             Next
    
62.             If FileSubCnt Then Print #1, vbCrLf; " "; "Get total "; FileSubCnt; " SubCodes in File <<"; myFile; ">>" Else Print #1, "No SubCode Exist"
    
63.         End With
    
64.         Windows(myFile).Close False
    
65.         myFile = Dir
    
66.         FileCount = FileCount + 1
    
67.     Loop Until myFile = ""
    
68.     Application.ScreenUpdating = True
    
69.    
    
70.     Print #1, vbCrLf; String(20, "="); vbCrLf; "  "; FileCount; " Files Checked"
    
71.     Close #1
    
72.    
    
73.     MsgBox FileCount & " Files Checked !"
    
74. End Sub
    

复制代码

香川群子

考虑到调用Sub子过程可能会是跨模块之间的调用……

所以附件做了更新：

1. Sub SubCodeCopy2() 'by kagawa 2014/02/06
   
2.    
   
3.     With Application.FileDialog(msoFileDialogFolderPicker)
   
4.         If .Show Then myPath = .SelectedItems(1) Else Exit Sub
   
5.     End With
   
6.    
   
7.     Open ActiveWorkbook.Path & "" & Replace(Mid(myPath, 4), "", "_") & "_VBASubCode2.txt" For Output As #1
   
8.     Print #1, myPath; vbCrLf
   
9.    
   
10.     Application.ScreenUpdating = False
    
11.     Application.DisplayAlerts = False
    
12.     myFile = Dir(myPath & "\*.xls")
    
13.     Do
    
14.         On Error Resume Next
    
15.         With Workbooks.Open(myFile)
    
16.             FileSubCnt = 0
    
17.             mySubName = ""
    
18.             Print #1, "  "; vbCrLf; String(20, "="); vbCrLf; myFile; vbCrLf; "  "
    
19.             For Each vbc In .VBProject.VBComponents
    
20.                 With vbc.CodeModule
    
21.                     If .CountOfLines Then
    
22.                         For i = 1 To .CountOfLines
    
23.                             myStr = .Lines(i, 1)
    
24.                             If myStr Like "Sub *" Or myStr Like " Sub *" Then
    
25.                                 myStr = Mid(myStr, InStr(myStr, "Sub ") + 4)
    
26.                                 myStr = Left(myStr, InStr(myStr, "(") - 1)
    
27.                                 mySubName = mySubName & "|" & myStr
    
28.                             End If
    
29.                         Next
    
30.                     End If
    
31.                 End With
    
32.             Next
    
33.             
    
34.             mySub = Split(mySubName, "|")
    
35.             mySubName = "|"
    
36.             For Each vbc In .VBProject.VBComponents
    
37.                 With vbc.CodeModule
    
38.                     If .CountOfLines Then
    
39.                         For j = 1 To UBound(mySub)
    
40.                             For i = 1 To .CountOfLines
    
41.                                 myStr = Trim(.Lines(i, 1))
    
42.                                 If myStr = mySub(j) Or myStr Like mySub(j) & " ,*" Or myStr = "Call " & mySub(j) Or myStr Like "Call " & mySub(j) & "(*" Then
    
43.                                     If InStr(mySubName, "|" & mySub(j) & "|") = 0 Then mySubName = mySubName & mySub(j) & "|"
    
44.                                 End If
    
45.                             Next
    
46.                         Next
    
47.                     End If
    
48.                End With
    
49.             Next
    
50.             
    
51.             If mySubName <> "|" Then
    
52.                 mySub = Split(mySubName, "|")
    
53.                 For Each vbc In .VBProject.VBComponents
    
54.                     With vbc.CodeModule
    
55.                         If .CountOfLines Then
    
56.                             SubCnt = 0
    
57.     '                        Print #1, " "; vbCrLf; String(10, "-"); .Name; String(10, "-"); vbCrLf
    
58.                             For j = 1 To UBound(mySub) - 1
    
59.                                 For i = 1 To .CountOfLines
    
60.                                     myStr = .Lines(i, 1)
    
61.                                     If myStr Like "*Sub " & mySub(j) & "*" Then flag = True: SubCnt = SubCnt + 1: If SubCnt = 1 Then Print #1, " "; vbCrLf; String(10, "-"); .Name; String(10, "-"); vbCrLf Else Print #1, " "; vbCrLf
    
62.                                     If flag And myStr Like "*End Sub*" Then flag = False: Print #1, myStr; vbCrLf
    
63.                                     If flag Then Print #1, myStr
    
64.                                 Next
    
65.                             Next
    
66.                             If SubCnt Then Print #1, vbCrLf; " "; "Get "; SubCnt; " SubCodes in Module ["; .Name; "]"
    
67.                             FileSubCnt = FileSubCnt + SubCnt
    
68.                         End If
    
69.                     End With
    
70.                 Next
    
71.             End If
    
72.             If FileSubCnt Then Print #1, vbCrLf; " "; "Get total "; FileSubCnt; " SubCodes in File <<"; myFile; ">>" Else Print #1, "No SubCode Exist"
    
73.         End With
    
74.         Windows(myFile).Close False
    
75.         myFile = Dir
    
76.         FileCount = FileCount + 1
    
77.     Loop Until myFile = ""
    
78.     Application.ScreenUpdating = True
    
79.    
    
80.     Print #1, vbCrLf; String(20, "="); vbCrLf; "  "; FileCount; " Files Checked"
    
81.     Close #1
    
82.    
    
83.     MsgBox FileCount & " Files Checked !"
    
84. End Sub

复制代码

香川群子

测试发现bug……因为没有按完整路径引用、无法打开文件。

请看更新后的附件。