|
本帖最后由 张雄友 于 2013-8-24 18:12 编辑
如何将本工作簿中的所有代码导出来.
包括工作表代码,工作簿代码,模块代码全部导出来.
- Sub 导出代码和模块()
- '开启VBA模型访问信任
- Call TrustVBA
- '备份代码,模块,窗体
- Call BakupModule(ThisWorkbook.Name, ThisWorkbook.Path & Application.PathSeparator & ThisWorkbook.Name & ".txt")
- End Sub
- Sub BakupModule(strWorkbook As String, strTxtFile As String)
- ' 参数1:要备份的的工作簿名
- ' 参数2:要导出的TXT文件
- Dim vbe As Object
- Dim vbc As Object
- Dim wb As Workbook
- Dim strTxt As String
- Dim fn As Integer
- On Error Resume Next
- Set wb = Workbooks(strWorkbook)
- If wb Is Nothing Then
- MsgBox "找到不指定的工作簿窗口,请确认是否有打开"
- Exit Sub
- End If
- If wb.HasVBProject Then
- '检测是否有保护
- If wb.VBProject.Protection Then
- MsgBox strWorkbook & " 有VBA密码保护,请先取消密码保护", vbCritical + vbOK
- Set wb = Nothing
- Exit Sub
- End If
- Set vbe = wb.VBProject.VBComponents
- For Each vbc In vbe
- With vbc.codemodule
- If .countoflines Then
- strTxt = strTxt & "'" & String(20, "-") & .Name & String(20, "-") & vbCrLf
- strTxt = strTxt & .Lines(1, .countoflines) & vbCrLf & vbCrLf
- End If
- End With
- Next
- On Error GoTo ErrorHandler
- fn = FreeFile()
- Open strTxtFile For Output Access Write As #fn
- Print #fn, strTxt
- Close #fn
- MsgBox "代码导出完成" & vbCrLf & strTxtFile, vbInformation + vbOKOnly
- Else
- MsgBox "指定的工作簿 " & strWorkbook & " 无代码可备份", vbInformation + vbOKOnly
- End If
- Exit Sub
- ErrorHandler:
- MsgBox Err.Number & vbCrLf & Err.Description
- End Sub
- Function TrustVBA(Optional ByVal KeyValue = 1)
- Dim strKey1 As String, strKey2 As String, strKey3 As String, strKey4 As String
- Dim KeyValue1, KeyValue2
- Dim strVersion As String
- On Error Resume Next
- strVersion = Application.Version
- strKey1 = "HKEY_CURRENT_USER\Software\Microsoft\Office" & strVersion & "\Excel\Security\AccessVBOM"
- strKey2 = "HKEY_CURRENT_USER\Software\Microsoft\Office" & strVersion & "\Excel\Security\Level"
- strKey3 = "HKEY_LOCAL_MACHINE\Software\Microsoft\Office" & strVersion & "\Excel\Security\AccessVBOM"
- strKey4 = "HKEY_LOCAL_MACHINE\Software\Microsoft\Office" & strVersion & "\Excel\Security\Level"
- 'AccessVBOM 允许访问VBA对象
- Call WriteReg(strKey1, KeyValue, "REG_DWORD")
- Call WriteReg(strKey2, KeyValue, "REG_DWORD")
- Call WriteReg(strKey3, KeyValue, "REG_DWORD")
- Call WriteReg(strKey4, KeyValue, "REG_DWORD")
- End Function
- Sub WriteReg(strkey As String, Value As Variant, ValueType As String)
- On Error Resume Next
- Dim objWshell As Object
- Set objWshell = CreateObject("WScript.Shell")
- If ValueType = "" Then
- objWshell.RegWrite strkey, Value
- Else
- objWshell.RegWrite strkey, Value, ValueType
- End If
- Set objWshell = Nothing
- End Sub
复制代码
|
|