龙网论坛

 找回密码
 注册
查看: 2662|回复: 0
收起左侧

[办公] VBA工程密码移除与保护

[复制链接]
发表于 2015-7-16 15:36 | 显示全部楼层 |阅读模式
  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
复制代码
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|龙网论坛 ( 辽ICP备06014320号 )

GMT+8, 2022-9-26 16:40

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

快速回复 返回顶部 返回列表