设为首页收藏本站
开启辅助访问

Excel精英培训网

 找回密码
 注册
Excel精英培训网»论坛 › Excel 求助区 › Excel VBA开发 › 想通过代码删除指定工作簿所有代码
数据透视表40+个常用小技巧，让你一次学会！
返回列表 发新帖
查看: 2412|回复: 6

[已解决]想通过代码删除指定工作簿所有代码

[复制链接]
发表于 2013-7-23 12:50 | 显示全部楼层 |阅读模式
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
本帖最后由 我心飞翔410 于 2013-7-23 13:16 编辑

我知道某个工作簿路径 “新建 Microsoft Excel 工作表.xlsm”   想删除里面的所有宏文件 包括移除模块
最佳答案
月排行榜 / 总排行榜
hwc2ycy
2013-7-23 13:53
  1. Sub 清除代码和模块()
  2.     '开启VBA模型访问信任
  3.     Call TrustVBA
  4.    
  5.     '清除指定工作簿的代码和模块
  6.     Call clearModule(ThisWorkbook.Name)
  7. End Sub

  9. Sub clearModule(strWorkbook As String)
  10.     Dim vbe As Object
  11.     Dim vbc As Object
  12.     Dim wb As Workbook
  13.    
  14.     On Error Resume Next
  15.    
  16.     Set wb = Workbooks(strWorkbook)
  17.    
  18.     If wb Is Nothing Then
  19.         MsgBox "找到不指定的工作簿窗口，请确认是否有打开"
  20.         Exit Sub
  21.     End If
  22.    
  23.     If wb.HasVBProject Then
  24.         '检测是否有保护
  25.         If wb.VBProject.Protection Then
  26.             MsgBox strWorkbook & " 有VBA密码保护，请先取消密码保护", vbCritical + vbokok
  27.             Set wb = Nothing
  28.             Exit Sub
  29.         End If
  30.         
  31.         Set vbe = wb.VBProject.VBComponents
  32.         
  33.         For Each vbc In vbe
  34.             Select Case vbc.Type
  35.                 Case 1, 2, 3
  36.                     vbe.Remove vbc
  37.                 Case 100
  38.                     With vbc.CodeModule
  39.                         .DeleteLines 1, .CountOfLines
  40.                     End With
  41.             End Select
  42.         Next
  43.     End If

  45. 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

  53.     strVersion = Application.Version

  55.     strKey1 = "HKEY_CURRENT_USER\Software\Microsoft\Office" & strVersion & "\Excel\Security\AccessVBOM"
  56.     strKey2 = "HKEY_CURRENT_USER\Software\Microsoft\Office" & strVersion & "\Excel\Security\Level"
  57.     strKey3 = "HKEY_LOCAL_MACHINE\Software\Microsoft\Office" & strVersion & "\Excel\Security\AccessVBOM"
  58.     strKey4 = "HKEY_LOCAL_MACHINE\Software\Microsoft\Office" & strVersion & "\Excel\Security\Level"
  59.     '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")

  66. End Function

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

使用道具 举报

工作中最常用的函数公式，全印在一张超大的鼠标垫上
hwc2ycy
发表于 2013-7-23 13:45 | 显示全部楼层
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
  1. Option Explicit


  4. Sub 清除代码和模块()
  5.     Call TrustVBA
  6.     Call clearModule(ThisWorkbook.Name)
  7. End Sub

  9. Sub clearModule(strworkbook As String)
  10.     Dim vbe As Object
  11.     Dim vbc As Object
  12.     Set vbe = Workbooks(strworkbook).VBProject.VBComponents
  13.     For Each vbc In vbe
  14.         Debug.Print vbc.Name, vbc.Type

  16.         Select Case vbc.Type
  17.             Case 1, 2, 3
  18.                 vbe.Remove vbc
  19.             Case 100
  20.                 With vbc.CodeModule
  21.                     .DeleteLines 1, .CountOfLines
  22.                 End With
  23.         End Select
  24.     Next
  25. End Sub

  27. Function TrustVBA(Optional ByVal KeyValue = 1)
  28.     Dim strKey1 As String, strKey2 As String, strKey3 As String, strKey4 As String
  29.     Dim KeyValue1, KeyValue2
  30.     Dim strVersion As String
  31.     On Error Resume Next

  33.     strVersion = Application.Version

  35.     strKey1 = "HKEY_CURRENT_USER\Software\Microsoft\Office" & strVersion & "\Excel\Security\AccessVBOM"
  36.     strKey2 = "HKEY_CURRENT_USER\Software\Microsoft\Office" & strVersion & "\Excel\Security\Level"
  37.     strKey3 = "HKEY_LOCAL_MACHINE\Software\Microsoft\Office" & strVersion & "\Excel\Security\AccessVBOM"
  38.     strKey4 = "HKEY_LOCAL_MACHINE\Software\Microsoft\Office" & strVersion & "\Excel\Security\Level"
  39.     'AccessVBOM 允许访问VBA对象

  41.     Call WriteReg(strKey1, KeyValue, "REG_DWORD")
  42.     Call WriteReg(strKey2, KeyValue, "REG_DWORD")
  43.     Call WriteReg(strKey3, KeyValue, "REG_DWORD")
  44.     Call WriteReg(strKey4, KeyValue, "REG_DWORD")

  46. End Function

  48. Sub WriteReg(strkey As String, Value As Variant, ValueType As String)
  49.     Dim objWshell As Object
  50.     Set objWshell = CreateObject("WScript.Shell")
  51.     If ValueType = "" Then
  52.         objWshell.RegWrite strkey, Value
  53.     Else
  54.         objWshell.RegWrite strkey, Value, ValueType
  55.     End If
  56.     Set objWshell = Nothing
  57. End Sub
复制代码
回复

使用道具 举报

hwc2ycy
发表于 2013-7-23 13:46 | 显示全部楼层
工作中最常用的Excel函数公式，全印在一张鼠标垫上
Call clearModule(ThisWorkbook.Name)
调用的时候，直接改 thisworkbook.name 为要删除代码和模块的工作簿。
还有个BUG得改下。
回复

使用道具 举报

hwc2ycy
发表于 2013-7-23 13:53 | 显示全部楼层    本楼为最佳答案   
  1. Sub 清除代码和模块()
  2.     '开启VBA模型访问信任
  3.     Call TrustVBA
  4.    
  5.     '清除指定工作簿的代码和模块
  6.     Call clearModule(ThisWorkbook.Name)
  7. End Sub

  9. Sub clearModule(strWorkbook As String)
  10.     Dim vbe As Object
  11.     Dim vbc As Object
  12.     Dim wb As Workbook
  13.    
  14.     On Error Resume Next
  15.    
  16.     Set wb = Workbooks(strWorkbook)
  17.    
  18.     If wb Is Nothing Then
  19.         MsgBox "找到不指定的工作簿窗口，请确认是否有打开"
  20.         Exit Sub
  21.     End If
  22.    
  23.     If wb.HasVBProject Then
  24.         '检测是否有保护
  25.         If wb.VBProject.Protection Then
  26.             MsgBox strWorkbook & " 有VBA密码保护，请先取消密码保护", vbCritical + vbokok
  27.             Set wb = Nothing
  28.             Exit Sub
  29.         End If
  30.         
  31.         Set vbe = wb.VBProject.VBComponents
  32.         
  33.         For Each vbc In vbe
  34.             Select Case vbc.Type
  35.                 Case 1, 2, 3
  36.                     vbe.Remove vbc
  37.                 Case 100
  38.                     With vbc.CodeModule
  39.                         .DeleteLines 1, .CountOfLines
  40.                     End With
  41.             End Select
  42.         Next
  43.     End If

  45. 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

  53.     strVersion = Application.Version

  55.     strKey1 = "HKEY_CURRENT_USER\Software\Microsoft\Office" & strVersion & "\Excel\Security\AccessVBOM"
  56.     strKey2 = "HKEY_CURRENT_USER\Software\Microsoft\Office" & strVersion & "\Excel\Security\Level"
  57.     strKey3 = "HKEY_LOCAL_MACHINE\Software\Microsoft\Office" & strVersion & "\Excel\Security\AccessVBOM"
  58.     strKey4 = "HKEY_LOCAL_MACHINE\Software\Microsoft\Office" & strVersion & "\Excel\Security\Level"
  59.     '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")

  66. End Function

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

使用道具 举报

 楼主| 发表于 2013-7-23 14:08 | 显示全部楼层
太长了 吗 不是有个'         For Each VBC In ThisWorkbook.VBProject.VBComponents   '删除所有宏文件
'
'             VBC.CodeModule.DeleteLines 1, VBC.CodeModule.CountOfLines
'
'         Next
回复

使用道具 举报

 楼主| 发表于 2013-7-23 17:04 | 显示全部楼层
呵呵 学习了 赞
回复

使用道具 举报

hwc2ycy
发表于 2013-7-29 09:09 | 显示全部楼层
汗，这么写错了，
MsgBox strWorkbook & " 有VBA密码保护，请先取消密码保护", vbCritical + vbokok

改成
MsgBox strWorkbook & " 有VBA密码保护，请先取消密码保护", vbCritical + vbokonly
回复

使用道具 举报

返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

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

GMT+8, 2024-4-25 16:23 , Processed in 1.337663 second(s), 7 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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