[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