VBA加解密

使用方法： 很简单 ，两种使用方法

      第一： 建立一个excel文档， 工具-》宏-》visual basci

                   将以上代码全部拷贝进去 保存 退出

                  重新打开那个excel，工具-》宏-》宏 可以看到两个

                分别是moveprotect 和 setprotect

                解密的话点moveprotect    运行

                  加密的话就是setprotect 运行

    第二： 建立一个excel 打开 ，视图-》工具栏-》visual basic

                然后可以在excel里建立连个按钮，caption分别是命名为 加密 解密

                将moveprotect中的代码拷贝到 解密 按钮的相应中去

                  将setprotect中的代码拷贝到   加密 按钮的响应中去

代码：

'去除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)
    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