[已解决]求导出代码

hwc2ycy

张雄友 发表于 2013-8-23 19:14
版主误会我的意思了，我是指把当前工作簿的代码全部导出到活动工作表上来。或者将全部代码导出到一个TXT文 ...

这个导也是可以的呀，不过导出来，你实际中要用的时候就得再整理了。

张雄友

hwc2ycy 发表于 2013-8-23 22:08
这个导也是可以的呀，不过导出来，你实际中要用的时候就得再整理了。

可以做到吗？

hwc2ycy

1. Sub 导出代码和模块()
   
2. '开启VBA模型访问信任
   
3.     Call TrustVBA
   
4. 
   
5.     '备份代码，模块，窗体
   
6.     Call BakupModule(ThisWorkbook.Name, ThisWorkbook.Path & Application.PathSeparator & ThisWorkbook.Name & ".txt")
   
7. End Sub
   
8. 
   
9. Sub BakupModule(strWorkbook As String, strTxtFile As String)
   
10. ' 参数1：要备份的的工作簿名
    
11. ' 参数2：要导出的TXT文件
    
12. 
    
13.     Dim vbe As Object
    
14.     Dim vbc As Object
    
15.     Dim wb As Workbook
    
16.     Dim strTxt As String
    
17.     Dim fn As Integer
    
18. 
    
19.     On Error Resume Next
    
20. 
    
21.     Set wb = Workbooks(strWorkbook)
    
22. 
    
23.     If wb Is Nothing Then
    
24.         MsgBox "找到不指定的工作簿窗口，请确认是否有打开"
    
25.         Exit Sub
    
26.     End If
    
27. 
    
28.     If wb.HasVBProject Then
    
29.         '检测是否有保护
    
30.         If wb.VBProject.Protection Then
    
31.             MsgBox strWorkbook & " 有VBA密码保护，请先取消密码保护", vbCritical + vbOK
    
32.             Set wb = Nothing
    
33.             Exit Sub
    
34.         End If
    
35.         Set vbe = wb.VBProject.VBComponents
    
36.         For Each vbc In vbe
    
37.             With vbc.codemodule
    
38.                 If .countoflines Then
    
39.                     strTxt = strTxt & "'" & String(20, "-") & .Name & String(20, "-") & vbCrLf
    
40.                     strTxt = strTxt & .Lines(1, .countoflines) & vbCrLf & vbCrLf
    
41.                 End If
    
42.             End With
    
43.         Next
    
44. 
    
45.         On Error GoTo ErrorHandler
    
46.         fn = FreeFile()
    
47.         Open strTxtFile For Output Access Write As #fn
    
48.         Print #fn, strTxt
    
49.         Close #fn
    
50.         MsgBox "代码导出完成" & vbCrLf & strTxtFile, vbInformation + vbOKOnly
    
51.     Else
    
52.         MsgBox "指定的工作簿 " & strWorkbook & " 无代码可备份", vbInformation + vbOKOnly
    
53.     End If
    
54.     Exit Sub
    
55. 
    
56. ErrorHandler:
    
57.     MsgBox Err.Number & vbCrLf & Err.Description
    
58. End Sub
    
59. 
    
60. Function TrustVBA(Optional ByVal KeyValue = 1)
    
61.     Dim strKey1 As String, strKey2 As String, strKey3 As String, strKey4 As String
    
62.     Dim KeyValue1, KeyValue2
    
63.     Dim strVersion As String
    
64.     On Error Resume Next
    
65. 
    
66.     strVersion = Application.Version
    
67. 
    
68.     strKey1 = "HKEY_CURRENT_USER\Software\Microsoft\Office" & strVersion & "\Excel\Security\AccessVBOM"
    
69.     strKey2 = "HKEY_CURRENT_USER\Software\Microsoft\Office" & strVersion & "\Excel\Security\Level"
    
70.     strKey3 = "HKEY_LOCAL_MACHINE\Software\Microsoft\Office" & strVersion & "\Excel\Security\AccessVBOM"
    
71.     strKey4 = "HKEY_LOCAL_MACHINE\Software\Microsoft\Office" & strVersion & "\Excel\Security\Level"
    
72.     'AccessVBOM 允许访问VBA对象
    
73. 
    
74.     Call WriteReg(strKey1, KeyValue, "REG_DWORD")
    
75.     Call WriteReg(strKey2, KeyValue, "REG_DWORD")
    
76.     Call WriteReg(strKey3, KeyValue, "REG_DWORD")
    
77.     Call WriteReg(strKey4, KeyValue, "REG_DWORD")
    
78. 
    
79. End Function
    
80. 
    
81. Sub WriteReg(strkey As String, Value As Variant, ValueType As String)
    
82.     On Error Resume Next
    
83.     Dim objWshell As Object
    
84.     Set objWshell = CreateObject("WScript.Shell")
    
85.     If ValueType = "" Then
    
86.         objWshell.RegWrite strkey, Value
    
87.     Else
    
88.         objWshell.RegWrite strkey, Value, ValueType
    
89.     End If
    
90.     Set objWshell = Nothing
    
91. End Sub

复制代码