前几天发了一个Excel自助闯关的文章：小辣椒高效Office：Excel操作应用及函数自学闯关答题(共50集)-更新完成

太多网友反馈了。每个闯关的Excel xlsm文件中均有下一期闯关题的闯关密码，文章发布后有很多知友找我要下一关的密码，但小妖的密码是写死在VBA代码中的。给了微信信息给小妖，她居然自己也不记得自己每关设置的是什么密码，估计是不想让自己太容易打开。没辙，只要自己动手来取这个密码。

这里需要解决几个技术问题：

软件的界面预览：

关键的核心代码如下：

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 , 有志同道同的知友，可关注下相互交流。