Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 3139|回复: 12

[已解决]求导出代码

[复制链接]
发表于 2013-8-23 18:17 | 显示全部楼层 |阅读模式
本帖最后由 张雄友 于 2013-8-24 18:12 编辑

如何将本工作簿中的所有代码导出来.

包括工作表代码,工作簿代码,模块代码全部导出来.


最佳答案
2013-8-24 09:08
  1. Sub 导出代码和模块()
  2. '开启VBA模型访问信任
  3.     Call TrustVBA

  4.     '备份代码,模块,窗体
  5.     Call BakupModule(ThisWorkbook.Name, ThisWorkbook.Path & Application.PathSeparator & ThisWorkbook.Name & ".txt")
  6. End Sub

  7. Sub BakupModule(strWorkbook As String, strTxtFile As String)
  8. ' 参数1:要备份的的工作簿名
  9. ' 参数2:要导出的TXT文件

  10.     Dim vbe As Object
  11.     Dim vbc As Object
  12.     Dim wb As Workbook
  13.     Dim strTxt As String
  14.     Dim fn As Integer

  15.     On Error Resume Next

  16.     Set wb = Workbooks(strWorkbook)

  17.     If wb Is Nothing Then
  18.         MsgBox "找到不指定的工作簿窗口,请确认是否有打开"
  19.         Exit Sub
  20.     End If

  21.     If wb.HasVBProject Then
  22.         '检测是否有保护
  23.         If wb.VBProject.Protection Then
  24.             MsgBox strWorkbook & " 有VBA密码保护,请先取消密码保护", vbCritical + vbOK
  25.             Set wb = Nothing
  26.             Exit Sub
  27.         End If
  28.         Set vbe = wb.VBProject.VBComponents
  29.         For Each vbc In vbe
  30.             With vbc.codemodule
  31.                 If .countoflines Then
  32.                     strTxt = strTxt & "'" & String(20, "-") & .Name & String(20, "-") & vbCrLf
  33.                     strTxt = strTxt & .Lines(1, .countoflines) & vbCrLf & vbCrLf
  34.                 End If
  35.             End With
  36.         Next

  37.         On Error GoTo ErrorHandler
  38.         fn = FreeFile()
  39.         Open strTxtFile For Output Access Write As #fn
  40.         Print #fn, strTxt
  41.         Close #fn
  42.         MsgBox "代码导出完成" & vbCrLf & strTxtFile, vbInformation + vbOKOnly
  43.     Else
  44.         MsgBox "指定的工作簿 " & strWorkbook & " 无代码可备份", vbInformation + vbOKOnly
  45.     End If
  46.     Exit Sub

  47. ErrorHandler:
  48.     MsgBox Err.Number & vbCrLf & Err.Description
  49. End Sub

  50. Function TrustVBA(Optional ByVal KeyValue = 1)
  51.     Dim strKey1 As String, strKey2 As String, strKey3 As String, strKey4 As String
  52.     Dim KeyValue1, KeyValue2
  53.     Dim strVersion As String
  54.     On Error Resume Next

  55.     strVersion = Application.Version

  56.     strKey1 = "HKEY_CURRENT_USER\Software\Microsoft\Office" & strVersion & "\Excel\Security\AccessVBOM"
  57.     strKey2 = "HKEY_CURRENT_USER\Software\Microsoft\Office" & strVersion & "\Excel\Security\Level"
  58.     strKey3 = "HKEY_LOCAL_MACHINE\Software\Microsoft\Office" & strVersion & "\Excel\Security\AccessVBOM"
  59.     strKey4 = "HKEY_LOCAL_MACHINE\Software\Microsoft\Office" & strVersion & "\Excel\Security\Level"
  60.     'AccessVBOM 允许访问VBA对象

  61.     Call WriteReg(strKey1, KeyValue, "REG_DWORD")
  62.     Call WriteReg(strKey2, KeyValue, "REG_DWORD")
  63.     Call WriteReg(strKey3, KeyValue, "REG_DWORD")
  64.     Call WriteReg(strKey4, KeyValue, "REG_DWORD")

  65. End Function

  66. Sub WriteReg(strkey As String, Value As Variant, ValueType As String)
  67.     On Error Resume Next
  68.     Dim objWshell As Object
  69.     Set objWshell = CreateObject("WScript.Shell")
  70.     If ValueType = "" Then
  71.         objWshell.RegWrite strkey, Value
  72.     Else
  73.         objWshell.RegWrite strkey, Value, ValueType
  74.     End If
  75.     Set objWshell = Nothing
  76. End Sub
复制代码

求导出代码.rar

9.05 KB, 下载次数: 3

excel精英培训的微信平台,每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
发表于 2013-8-23 18:24 | 显示全部楼层
回复

使用道具 举报

 楼主| 发表于 2013-8-23 18:25 | 显示全部楼层
hwc2ycy 发表于 2013-8-23 18:24
这个操作VBE对象即可。

有动画吗?怎么操作的?
回复

使用道具 举报

发表于 2013-8-23 18:42 | 显示全部楼层
  1. Sub 清除代码和模块()
  2. '开启VBA模型访问信任
  3.     Call TrustVBA

  4.     '备份代码,模块,窗体
  5.     Call BakupModule(ThisWorkbook.Name, ThisWorkbook.Path & Application.PathSeparator)
  6. End Sub

  7. Sub BakupModule(strWorkbook As String, strPath As String)
  8. ' 参数1:要导出的工作簿名
  9. '参数2:要备份的目录

  10.     Dim vbe As Object
  11.     Dim vbc As Object
  12.     Dim wb As Workbook
  13.     Dim strFilename As String
  14.     Dim strMsg As String

  15.     On Error Resume Next

  16.     Set wb = Workbooks(strWorkbook)

  17.     If wb Is Nothing Then
  18.         MsgBox "找到不指定的工作簿窗口,请确认是否有打开"
  19.         Exit Sub
  20.     End If

  21.     If wb.HasVBProject Then
  22.         '检测是否有保护
  23.         If wb.VBProject.Protection Then
  24.             MsgBox strWorkbook & " 有VBA密码保护,请先取消密码保护", vbCritical + vbOK
  25.             Set wb = Nothing
  26.             Exit Sub
  27.         End If

  28.         Set vbe = wb.VBProject.VBComponents

  29.         For Each vbc In vbe
  30.             strFilename = strPath & vbc.Name
  31.             Debug.Print vbc.Type, vbc.Name
  32.             Select Case vbc.Type
  33.                 Case 1
  34.                     strFilename = strFilename & ".bas"
  35.                 Case 2, 100
  36.                     strFilename = strFilename & ".cls"
  37.                 Case 3
  38.                     strFilename = strFilename & ".frm"
  39.             End Select
  40.             If Len(Dir(strFilename)) > 0 Then Kill strFilename
  41.             vbc.Export (strFilename)
  42.             strMsg = strMsg & strFilename & vbCrLf
  43.         Next
  44.         MsgBox strMsg, vbInformation + vbOKOnly
  45.     End If

  46. End Sub

  47. Function TrustVBA(Optional ByVal KeyValue = 1)
  48.     Dim strKey1 As String, strKey2 As String, strKey3 As String, strKey4 As String
  49.     Dim KeyValue1, KeyValue2
  50.     Dim strVersion As String
  51.     On Error Resume Next

  52.     strVersion = Application.Version

  53.     strKey1 = "HKEY_CURRENT_USER\Software\Microsoft\Office" & strVersion & "\Excel\Security\AccessVBOM"
  54.     strKey2 = "HKEY_CURRENT_USER\Software\Microsoft\Office" & strVersion & "\Excel\Security\Level"
  55.     strKey3 = "HKEY_LOCAL_MACHINE\Software\Microsoft\Office" & strVersion & "\Excel\Security\AccessVBOM"
  56.     strKey4 = "HKEY_LOCAL_MACHINE\Software\Microsoft\Office" & strVersion & "\Excel\Security\Level"
  57.     'AccessVBOM 允许访问VBA对象

  58.     Call WriteReg(strKey1, KeyValue, "REG_DWORD")
  59.     Call WriteReg(strKey2, KeyValue, "REG_DWORD")
  60.     Call WriteReg(strKey3, KeyValue, "REG_DWORD")
  61.     Call WriteReg(strKey4, KeyValue, "REG_DWORD")

  62. End Function

  63. Sub WriteReg(strkey As String, Value As Variant, ValueType As String)
  64.     On Error Resume Next
  65.     Dim objWshell As Object
  66.     Set objWshell = CreateObject("WScript.Shell")
  67.     If ValueType = "" Then
  68.         objWshell.RegWrite strkey, Value
  69.     Else
  70.         objWshell.RegWrite strkey, Value, ValueType
  71.     End If
  72.     Set objWshell = Nothing
  73. End Sub
复制代码
回复

使用道具 举报

发表于 2013-8-23 18:43 | 显示全部楼层
在这些模块上面直接右键菜单,不是有个导出嘛。
回复

使用道具 举报

 楼主| 发表于 2013-8-23 18:52 | 显示全部楼层
hwc2ycy 发表于 2013-8-23 18:43
在这些模块上面直接右键菜单,不是有个导出嘛。

有2个问题:
第一,一个一个导出不是很麻烦?我的意思是一下子全部导出。

第二,Sub 清除代码和模块()'开启VBA模型访问信任
    Call TrustVBA

    '备份代码,模块,窗体
    Call BakupModule(ThisWorkbook.Name, ThisWorkbook.Path & Application.PathSeparator)
End Sub

清除代码这个代码有KILL ,会不会删除电脑里面的所有代码的?

回复

使用道具 举报

发表于 2013-8-23 19:04 | 显示全部楼层
张雄友 发表于 2013-8-23 18:52
有2个问题:
第一,一个一个导出不是很麻烦?我的意思是一下子全部导出。

那你导出的时候,最好是一个文件存在一个文件夹内,否则导出的话就会删除原有的。

用代码导出就是批量操作嘛。
当然,还有个方法,可以加上工作簿名做前缀,这样更好。
回复

使用道具 举报

发表于 2013-8-23 19:07 | 显示全部楼层
  1. Sub 导出代码和模块()
  2. '开启VBA模型访问信任
  3.     Call TrustVBA

  4.     '备份代码,模块,窗体
  5.     Call BakupModule(ThisWorkbook.Name, ThisWorkbook.Path & Application.PathSeparator)
  6. End Sub

  7. Sub BakupModule(strWorkbook As String, strPath As String)
  8. ' 参数1:要导出的工作簿名
  9. '参数2:要备份的目录

  10.     Dim vbe As Object
  11.     Dim vbc As Object
  12.     Dim wb As Workbook
  13.     Dim strFilename As String
  14.     Dim strMsg As String

  15.     On Error Resume Next

  16.     Set wb = Workbooks(strWorkbook)

  17.     If wb Is Nothing Then
  18.         MsgBox "找到不指定的工作簿窗口,请确认是否有打开"
  19.         Exit Sub
  20.     End If

  21.     If wb.HasVBProject Then
  22.         '检测是否有保护
  23.         If wb.VBProject.Protection Then
  24.             MsgBox strWorkbook & " 有VBA密码保护,请先取消密码保护", vbCritical + vbOK
  25.             Set wb = Nothing
  26.             Exit Sub
  27.         End If

  28.         Set vbe = wb.VBProject.VBComponents

  29.         For Each vbc In vbe
  30.             strFilename = strPath & strWorkbook & "-" & vbc.Name
  31.             Debug.Print vbc.Type, vbc.Name
  32.             Select Case vbc.Type
  33.                 Case 1
  34.                     strFilename = strFilename & ".bas"
  35.                 Case 2, 100
  36.                     strFilename = strFilename & ".cls"
  37.                 Case 3
  38.                     strFilename = strFilename & ".frm"
  39.             End Select
  40.             If Len(Dir(strFilename)) > 0 Then Kill strFilename
  41.             vbc.Export (strFilename)
  42.             strMsg = strMsg & strFilename & vbCrLf
  43.         Next
  44.         MsgBox strMsg, vbInformation + vbOKOnly
  45.     End If

  46. End Sub

  47. Function TrustVBA(Optional ByVal KeyValue = 1)
  48.     Dim strKey1 As String, strKey2 As String, strKey3 As String, strKey4 As String
  49.     Dim KeyValue1, KeyValue2
  50.     Dim strVersion As String
  51.     On Error Resume Next

  52.     strVersion = Application.Version

  53.     strKey1 = "HKEY_CURRENT_USER\Software\Microsoft\Office" & strVersion & "\Excel\Security\AccessVBOM"
  54.     strKey2 = "HKEY_CURRENT_USER\Software\Microsoft\Office" & strVersion & "\Excel\Security\Level"
  55.     strKey3 = "HKEY_LOCAL_MACHINE\Software\Microsoft\Office" & strVersion & "\Excel\Security\AccessVBOM"
  56.     strKey4 = "HKEY_LOCAL_MACHINE\Software\Microsoft\Office" & strVersion & "\Excel\Security\Level"
  57.     'AccessVBOM 允许访问VBA对象

  58.     Call WriteReg(strKey1, KeyValue, "REG_DWORD")
  59.     Call WriteReg(strKey2, KeyValue, "REG_DWORD")
  60.     Call WriteReg(strKey3, KeyValue, "REG_DWORD")
  61.     Call WriteReg(strKey4, KeyValue, "REG_DWORD")

  62. End Function

  63. Sub WriteReg(strkey As String, Value As Variant, ValueType As String)
  64.     On Error Resume Next
  65.     Dim objWshell As Object
  66.     Set objWshell = CreateObject("WScript.Shell")
  67.     If ValueType = "" Then
  68.         objWshell.RegWrite strkey, Value
  69.     Else
  70.         objWshell.RegWrite strkey, Value, ValueType
  71.     End If
  72.     Set objWshell = Nothing
  73. End Sub
复制代码
回复

使用道具 举报

发表于 2013-8-23 19:07 | 显示全部楼层
QQ截图20130823190554.jpg
回复

使用道具 举报

 楼主| 发表于 2013-8-23 19:14 | 显示全部楼层
hwc2ycy 发表于 2013-8-23 19:07

版主误会我的意思了,我是指把当前工作簿的代码全部导出到活动工作表上来。或者将全部代码导出到一个TXT文档中。

而不是导出一个代码一个模块的。
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-3-29 05:30 , Processed in 0.657478 second(s), 10 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表