[VBA][Tools]Excel VBA密碼破解工具（VBA實現）

VBA密碼破解

 

建立一個Excel活頁簿,Alt+F11 開啟VBA編輯器,建立一個模組 ,複製以下代碼即可,經測試已經通過.

'1>破解程式測試WIN98+OFFICE97,WinXP+Office2003破解成功。
'2>用以下代碼對VBA加密保護後用offkey 6.5-7.0及Advanced VBA pASSWORD Recovery專業版均無法破解出保護程式碼的密碼

 

Option Explicit
'移除VBA??保?
Sub MoveProtect()
   Dim FileName As String
   FileName = Application.GetOpenFilename("Excel檔案（*.xls & *.xla）,*.xls;*.xla", , "VBA破解")
   If FileName = CStr(False) Then
      Exit Sub
   Else
      VBAPassword FileName, False
   End If
End Sub

'?置VBA??保?
Sub SetProtect()
   Dim FileName As String
   FileName = Application.GetOpenFilename("Excel檔案（*.xls & *.xla）,*.xls;*.xla", , "VBA破解")
   If FileName = CStr(False) Then
      Exit Sub
   Else
      VBAPassword FileName, True
   End If
End Sub

Private Function VBAPassword(FileName As String, Optional Protect As Boolean = False)
     Dim i As Integer
     On Error Resume Next
     If Dir(FileName) = "" Then
        Exit Function
     Else
        FileCopy FileName, FileName & "_" & Format(Date, "YYYYMMDD") & Format(Time, "hhmmss") & ".bak"
        If Err.Number = "55" Then
            MsgBox "指定されたファイルは開けています。閉じてください。"
            Exit Function
        End If
     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 "このExcelに、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 "VBAパスワードは削除しました！......", 32, "提示"
     Else
        Dim MMs As String * 5
        MMs = "DPB="""
        Put #1, CMGs, MMs
        MsgBox "VBAパスワードは追加しました！......", 32, "提示"
     End If
     Close #1
End Function