VBA工程密码移除与保护

admin

1. '移除工作表VBA保护
   
2. Sub MoveProtect()
   
3.    Dim FileName As String
   
4.    FileName = Application.GetOpenFilename("Excel文件（*.xls & *.xla）,*.xls;*.xla", , "VBA破解")
   
5.    If FileName = CStr(False) Then
   
6.     Exit Sub
   
7.    Else
   
8.     VBAPassword FileName, False
   
9.    End If
   
10. End Sub
    
11. '--------------------------------------------------------------------------------
    
12. '设置VBA编码保护
    
13. Sub SetProtect()
    
14.    Dim FileName As String
    
15.    FileName = Application.GetOpenFilename("Excel文件（*.xls & *.xla）,*.xls;*.xla", , "VBA破解")
    
16.    If FileName = CStr(False) Then
    
17.     Exit Sub
    
18.    Else
    
19.     VBAPassword FileName, True
    
20.    End If
    
21. End Sub
    
22. '--------------------------------------------------------------------------------
    
23. Private Function VBAPassword(FileName As String, Optional Protect As Boolean = False)
    
24. If Dir(FileName) = "" Then
    
25.    Exit Function
    
26. Else
    
27.    FileCopy FileName, FileName & ".bak"
    
28. End If
    
29. Dim GetData As String * 5
    
30. Open FileName For Binary As #1
    
31. Dim CMGs As Long
    
32. Dim DPBo As Long
    
33. For i = 1 To LOF(1)
    
34.        Get #1, i, GetData
    
35.        If GetData = "CMG=""" Then CMGs = i
    
36.        If GetData = "[Host" Then DPBo = i - 2: Exit For
    
37. Next
    
38. If CMGs = 0 Then
    
39.    MsgBox "请先对VBA编码设置一个保护密码...", 32, "提示"
    
40.    Exit Function
    
41. End If
    
42. If Protect = False Then
    
43.    Dim St As String * 2
    
44.    Dim s20 As String * 1
    
45.   
    
46.    '取得一个0D0A十六进制字串
    
47.    Get #1, CMGs - 2, St
    
48.    '取得一个20十六制字串
    
49.    Get #1, DPBo + 16, s20
    
50.    '替换加密部份机码
    
51.    For i = CMGs To DPBo Step 2
    
52.           Put #1, i, St
    
53.    Next
    
54.   
    
55.    '加入不配对符号
    
56.    If (DPBo - CMGs) Mod 2 <> 0 Then
    
57.       Put #1, DPBo + 1, s20
    
58.    End If
    
59.    MsgBox "文件解密成功......", 32, "提示"
    
60. Else
    
61.    Dim MMs As String * 5
    
62.    MMs = "DPB="""
    
63.    Put #1, CMGs, MMs
    
64.    MsgBox "对文件特殊加密成功......", 32, "提示"
    
65. End If
    
66. Close #1
    
67. End Function

复制代码