'移除VBA编码保护(优化版)
Sub MoveProtect()
Dim FileName As String
FileName = Application.GetOpenFilename("Excel文件(*.xls;*.xlsm),*.xls;*.xlsm", , "VBA破解")
If FileName = "False" Then Exit Sub
VBAPassword FileName, False
End Sub
'设置VBA编码保护(优化版)
Sub SetProtect()
Dim FileName As String
FileName = Application.GetOpenFilename("Excel文件(*.xls;*.xlsm),*.xls;*.xlsm", , "VBA破解")
If FileName = "False" Then Exit Sub
VBAPassword FileName, True
End Sub
Private Function VBAPassword(FileName As String, Optional Protect As Boolean = False)
On Error GoTo ErrorHandler
If Dir(FileName) = "" Then
MsgBox "文件不存在!", vbExclamation, "错误"
Exit Function
End If
' 生成临时备份路径
Dim BackupPath As String
BackupPath = Environ("TEMP") & "\" & Format(Now, "yyyymmddhhnnss") & ".bak"
' 检查文件权限
If GetAttr(FileName) And vbReadOnly Then
MsgBox "文件为只读,请取消只读属性后重试!", vbExclamation, "错误"
Exit Function
End If
' 使用 FSO 安全复制
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FileExists(FileName) Then
FSO.CopyFile FileName, BackupPath, True
Else
MsgBox "无法创建备份文件!", vbExclamation, "错误"
Exit Function
End If
' 主处理逻辑
Dim GetData As String * 5
Open FileName For Binary As #1
Dim CMGs As Long, 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密码保护!", vbInformation, "提示"
Close #1
Exit Function
End If
If Protect = False Then
' 解密操作
Dim St As String * 2, s20 As String * 1
Get #1, CMGs - 2, St
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 "解密成功!", vbInformation, "完成"
Else
' 加密操作
Dim MMs As String * 5
MMs = "DPB="""""
Put #1, CMGs, MMs
MsgBox "加密成功!", vbInformation, "完成"
End If
Close #1
Exit Function
ErrorHandler:
Close #1
MsgBox "错误 " & Err.Number & ": " & Err.Description, vbCritical, "操作失败"
End Function
不晓得会不会被系统删代码
Sub MoveProtect()
Dim FileName As String
FileName = Application.GetOpenFilename("Excel文件(*.xls;*.xlsm),*.xls;*.xlsm", , "VBA破解")
If FileName = "False" Then Exit Sub
VBAPassword FileName, False
End Sub
'设置VBA编码保护(优化版)
Sub SetProtect()
Dim FileName As String
FileName = Application.GetOpenFilename("Excel文件(*.xls;*.xlsm),*.xls;*.xlsm", , "VBA破解")
If FileName = "False" Then Exit Sub
VBAPassword FileName, True
End Sub
Private Function VBAPassword(FileName As String, Optional Protect As Boolean = False)
On Error GoTo ErrorHandler
If Dir(FileName) = "" Then
MsgBox "文件不存在!", vbExclamation, "错误"
Exit Function
End If
' 生成临时备份路径
Dim BackupPath As String
BackupPath = Environ("TEMP") & "\" & Format(Now, "yyyymmddhhnnss") & ".bak"
' 检查文件权限
If GetAttr(FileName) And vbReadOnly Then
MsgBox "文件为只读,请取消只读属性后重试!", vbExclamation, "错误"
Exit Function
End If
' 使用 FSO 安全复制
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FileExists(FileName) Then
FSO.CopyFile FileName, BackupPath, True
Else
MsgBox "无法创建备份文件!", vbExclamation, "错误"
Exit Function
End If
' 主处理逻辑
Dim GetData As String * 5
Open FileName For Binary As #1
Dim CMGs As Long, 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密码保护!", vbInformation, "提示"
Close #1
Exit Function
End If
If Protect = False Then
' 解密操作
Dim St As String * 2, s20 As String * 1
Get #1, CMGs - 2, St
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 "解密成功!", vbInformation, "完成"
Else
' 加密操作
Dim MMs As String * 5
MMs = "DPB="""""
Put #1, CMGs, MMs
MsgBox "加密成功!", vbInformation, "完成"
End If
Close #1
Exit Function
ErrorHandler:
Close #1
MsgBox "错误 " & Err.Number & ": " & Err.Description, vbCritical, "操作失败"
End Function
不晓得会不会被系统删代码