两种方式破解VBA工程加密

两种方式破解VBA加密代码

第一种:

 1 Sub VBAPassword1() '你要解保护的Excel文件路径
 2     Filename = Application.GetOpenFilename("Excel文件(*.xls & *.xla & *.xlt),*.xls;*.xla;*.xlt", , "VBA破解")
 3     If Dir(Filename) = "" Then
 4         MsgBox "没找到相关文件,清重新设置。"
 5         Exit Sub
 6     Else
 7         FileCopy Filename, Filename & ".bak" '备份文件。
 8     End If
 9     Dim GetData As String * 5
10     Open Filename For Binary As #1
11     Dim CMGs As Long
12     Dim DPBo As Long
13     For i = 1 To LOF(1)
14         Get #1, i, GetData
15         If GetData = "CMG=""" Then CMGs = i
16         If GetData = "[Host" Then DPBo = i - 2: Exit For
17     Next
18     If CMGs = 0 Then
19         MsgBox "请先对VBA编码设置一个保护密码...", 32, "提示"
20         Exit Sub
21     End If
22     Dim St As String * 2
23     Dim s20 As String * 1
24     '取得一个0D0A十六进制字串
25     Get #1, CMGs - 2, St
26     '取得一个20十六制字串
27     Get #1, DPBo + 16, s20
28     '替换加密部份机码
29     For i = CMGs To DPBo Step 2
30         Put #1, i, St
31     Next
32     '加入不配对符号
33     If (DPBo - CMGs) Mod 2 <> 0 Then
34         Put #1, DPBo + 1, s20
35     End If
36     MsgBox "文件解密成功......", 32, "提示"
37     Close #1
38 End Sub

 

第二种:

 1     Option Explicit
 2     Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Long, Source As Long, ByVal Length As Long)
 3     Private Declare Function VirtualProtect Lib "kernel32" (lpAddress As Long, ByVal dwSize As Long, ByVal flNewProtect As Long, lpflOldProtect As Long) As Long
 4     Private Declare Function GetModuleHandleA Lib "kernel32" (ByVal lpModuleName As String) As Long
 5     Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
 6     Private Declare Function DialogBoxParam Lib "user32" Alias "DialogBoxParamA" (ByVal hInstance As Long, ByVal pTemplateName As Long, ByVal hWndParent As Long, ByVal lpDialogFunc As Long, ByVal dwInitParam As Long) As Integer
 7     Dim HookBytes(0 To 5) As Byte
 8     Dim OriginBytes(0 To 5) As Byte
 9     Dim pFunc As Long
10     Dim Flag As Boolean
11 Private Function GetPtr(ByVal Value As Long) As Long
12     GetPtr = Value
13 End Function
14 Public Sub RecoverBytes()
15     If Flag Then MoveMemory ByVal pFunc, ByVal VarPtr(OriginBytes(0)), 6
16 End Sub
17 Public Function Hook() As Boolean
18     Dim TmpBytes(0 To 5) As Byte
19     Dim p As Long
20     Dim OriginProtect As Long
21     Hook = False
22     pFunc = GetProcAddress(GetModuleHandleA("user32.dll"), "DialogBoxParamA")
23     If VirtualProtect(ByVal pFunc, 6, &H40, OriginProtect) <> 0 Then
24         MoveMemory ByVal VarPtr(TmpBytes(0)), ByVal pFunc, 6
25         If TmpBytes(0) <> &H68 Then
26             MoveMemory ByVal VarPtr(OriginBytes(0)), ByVal pFunc, 6
27             p = GetPtr(AddressOf MyDialogBoxParam)
28             HookBytes(0) = &H68
29             MoveMemory ByVal VarPtr(HookBytes(1)), ByVal VarPtr(p), 4
30             HookBytes(5) = &HC3
31             MoveMemory ByVal pFunc, ByVal VarPtr(HookBytes(0)), 6
32             Flag = True
33             Hook = True
34         End If
35     End If
36 End Function
37 Private Function MyDialogBoxParam(ByVal hInstance As Long, _
38 ByVal pTemplateName As Long, ByVal hWndParent As Long, _
39 ByVal lpDialogFunc As Long, ByVal dwInitParam As Long) As Integer
40     If pTemplateName = 4070 Then
41         MyDialogBoxParam = 1
42     Else
43         RecoverBytes
44         MyDialogBoxParam = DialogBoxParam(hInstance, pTemplateName, hWndParent, lpDialogFunc, dwInitParam)
45         Hook
46     End If
47 End Function
48 Sub Crack()
49     If Hook Then MsgBox "破解成功"
50 End Sub

 

posted @ 2021-12-03 16:38  VBA说  阅读(712)  评论(0编辑  收藏  举报