VBA打开已加密的Excel VBA工程文件并批量去除密码同时获取代码中指定内容
前几天发了一个Excel自助闯关的文章：小辣椒高效Office：Excel操作应用及函数自学闯关答题(共50集)-更新完成
太多网友反馈了。每个闯关的Excel xlsm文件中均有下一期闯关题的闯关密码，文章发布后有很多知友找我要下一关的密码，但小妖的密码是写死在VBA代码中的。给了微信信息给小妖，她居然自己也不记得自己每关设置的是什么密码，估计是不想让自己太容易打开。没辙，只要自己动手来取这个密码。
这里需要解决几个技术问题：
- 需要解密xlsm的VBA密码，由于xlsm手工有破解办法，我们10年前做 的 Excel O啦插件 居然还是可一如既往的轻松解密密码 ，但是这些方法和工具无法批量（无手工交互的情况下）去除50个甚至更多文件的密码，所以需要找一个批量解密的方法
- 发现xls 文件可以批量去除 vba密码
- 那需要增加一个批量将xlsm格式另存为xls格式的代码
- 循环所有vba模块及代码，搜索到关键处理 myPassword = " (小妖的密码设置处）
- 将所有密码 与 工作簿文件名 输出到指定的文件 或 显示出来
软件的界面预览：
关键的核心代码如下：
RemoveVBAPassword strNewFileName, False '去除Excel xls文件的VBA密码
' mySleep 1000
Set objWk = xlApp.Workbooks.Open(strNewFileName)
lngVbCompCnt = objWk.VBProject.VBComponents.count
For i = 1 To lngVbCompCnt
If objWk.VBProject.VBComponents(i).Type = 1 Then '判断是否模块
lngLines = objWk.VBProject.VBComponents(i).CodeModule.CountOfLines
For j = 1 To lngLines '循环模块代码中所有内容，找到我需要的关键内容
strLine = objWk.VBProject.VBComponents(i).CodeModule.Lines(j, 1)
intPos1 = InStr(strLine, "MyPassWord = """) 'MyPassword = "
If intPos1 = 0 Then
intPos1 = InStr(strLine, "MyPassword = """)
End If
If intPos1 > 0 Then
intPos2 = InStr(intPos1 + Len("MyPassWord = """) + 1, strLine, """")
If intPos2 > 0 Then
blnOk = True
strPass = Mid(strLine, intPos1 + Len("MyPassWord = """), intPos2 - intPos1 - Len("MyPassWord = """))
Debug.Print strFileName & ":" & strPass
Exit For
End If
End If
Next
If blnOk = True Then Exit For
End If
Next
objWk.Close False '不保存
其中代码调用了以上解密自定义函数
Private Function RemoveVBAPassword(FileName As String, Optional Protect As Boolean = False)
If Dir(FileName) = "" Then
Exit Function
Else
' FileCopy FileName, FileName & ".bak"
End If
Dim GetData As String * 5
Open FileName For Binary As #1
Dim CMGs As Long
Dim DPBo As Long
For i = 1 To LOF(1)
Get #1, i, GetData
If GetData = "CMG=""" Then CMGs = i
If GetData = "[Host" Then DPBo = i - 2: Exit For
Next
If CMGs = 0 Then
' MsgBox "请先对VBA编码设置一个保护密码...", 32, "提示"
Exit Function
End If
If Protect = False Then
Dim St As String * 2
Dim s20 As String * 1
'取得一个0D0A十六进制字串
Get #1, CMGs - 2, St
'取得一个20十六制字串
Get #1, DPBo + 16, s20
'替换加密部份机码
For i = CMGs To DPBo Step 2
Put #1, i, St
Next
'加入不配对符号
If (DPBo - CMGs) Mod 2 <> 0 Then
Put #1, DPBo + 1, s20
End If
' MsgBox "文件解密成功......", 32, "提示"
Else
Dim MMs As String * 5
MMs = "DPB="""
Put #1, CMGs, MMs
' MsgBox "对文件特殊加密成功......", 32, "提示"
End If
Close #1
End Function
10多年主要钻研Excel VBA 与 Access VBA , 有志同道同的知友，可关注下相互交流。