Dzwebs.Net

撰写电脑技术杂文十余年

VBA对Excel加密解密代码及对单元格的锁定

Admin | 2008-5-6 18:36:08 | 被阅次数 | 351406

温馨提示!

如果未能解决您的问题,请点击搜索;登陆可复制文章,点击登陆

-----------加密、解密源代码---------------

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

-----------代码结束---------------

知识扩展:锁定某工作薄所有工作表的某区域,让其无法输入(操作)

For i = 1 To Worksheets.Count
  Sheets(i).Cells.Locked = False
  Sheets(i).Range("C5:C10").Locked = True '指定区域
  Sheets(i).Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
Next


该杂文来自: Excel杂文

上一篇:VBA实现两表符合条件的某列数据的复制粘贴(包含隐

下一篇:将Excel选定的数据区域导出为图片的VBA代码

网站备案号:

网站备案号:滇ICP备11001339号-7

版权属性:

Copyright 2007-2021-forever Inc. all Rights Reserved.

联系方式:

Email:dzwebs@126.com QQ:83539231 访问统计