VBA学习(53)：用MD5加密解密，生成注册码，VBA应用程序一机一码注册

xwLink1996

于 2024-08-19 14:03:39 发布

阅读量72

点赞数 2

分类专栏： VBA学习文章标签： excel VBA

本文链接：https://blog.csdn.net/nianfen/article/details/141323707

版权

VBA学习专栏收录该内容

53 篇文章 1 订阅

订阅专栏

内容提要

MD5加密解密|完整代码

1、在工作簿“主程序MD5”里，用户窗体Usf_Login里，这仅为演示之用，无实质性的内容：

Private Sub CmdLogin_Click()
    Call BackTo
    Unload Me
End Sub

2、在工作簿“主程序MD5”里，用户窗体Usf_Reg里，用户注册窗口：

Dim clsGT As New GetInfo
Dim currStatus As Integer

Private Sub CmdCancel_Click()
    ThisWorkbook.Close savechanges:=True
End Sub

Private Sub CmdCopy_Click()
    If CopyTextToClipboard(currMachineCode) Then
        MsgBox "注册码已成功复制到剪贴板。"
    Else
        MsgBox "注册码复制失败。"
    End If
End Sub

Private Sub CmdRegister_Click()
    If Me.TxbRegisterCode = "" Then
        MsgBox "请输入正确的注册码！"
        Exit Sub
    Else
        If RegisterCodeShouldBe = Me.TxbRegisterCode Then
            MsgBox "注册成功！"
            Sheets("Settings").Range(clsGT.ValRngAddress("RegisterCode")).Value = Me.TxbRegisterCode
            currStatus = 1
            Usf_Login.Show
            Unload Me
        Else
            
            MsgBox "注册码不正确！"
            Exit Sub
            
        End If
        
    End If
End Sub

Private Sub CmdTrial_Click()
    If timeLeft > 0 Then
        Sheets("Settings").Range(clsGT.ValRngAddress("TimesLeft")).Value = timeLeft - 1
        ThisWorkbook.Save
        currStatus = 1
        Usf_Login.Show
        Unload Me
    Else
        MsgBox "试用次数已用完，请注册！"
        Exit Sub
    End If
End Sub

Private Sub UserForm_Initialize()
    Me.LbMachineCode.Caption = currMachineCode
    Me.CmdTrial.Caption = "试用(" & timeLeft & ")"
    '内部使用版隐藏付款码
    If clsGT.GetCurrInfo("InternalVersion") = "yes" Then
        Me.Height = Me.CmdCancel.Top + Me.CmdCancel.Height + 30
    End If
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    If currStatus <> 1 Then
        ThisWorkbook.Close savechanges:=True
    End If
End Sub

3、在工作簿“主程序MD5”里，模块myModule_Reg，复制到剪切板、自动运行等过程：

Public currMachineCode As String
Public RegisterCodeShouldBe As String
Public timeLeft As Integer

#If VBA7 Then
    Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
    Declare PtrSafe Function CloseClipboard Lib "user32" () As LongPtr
    Declare PtrSafe Function EmptyClipboard Lib "user32" () As LongPtr
    Declare PtrSafe Function SetClipboardData Lib "user32" (ByVal wFormat As LongPtr, ByVal hMem As LongPtr) As LongPtr
    Declare PtrSafe Function GlobalAlloc Lib "kernel32" (ByVal wFlags As LongPtr, ByVal dwBytes As LongPtr) As LongPtr
    Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
    Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
    Declare PtrSafe Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As LongPtr
#Else
    Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long
    Declare Function CloseClipboard Lib "user32" () As Long
    Declare Function EmptyClipboard Lib "user32" () As Long
    Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
    Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
    Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
    Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
    Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
#End If
Const GMEM_MOVEABLE = &H2
Const CF_TEXT = 1

Function CopyTextToClipboard(textToCopy As String) As Boolean
    Dim hMem As LongPtr, lpMem As LongPtr
    
    ' 打开剪贴板
    If OpenClipboard(0&) = 0 Then
        CopyTextToClipboard = False
        Exit Function
    End If
    
    ' 清空剪贴板内容
    EmptyClipboard
    
    ' 分配全局内存并锁定
    hMem = GlobalAlloc(GMEM_MOVEABLE, Len(textToCopy) + 1)
    lpMem = GlobalLock(hMem)
    
    ' 将文本复制到全局内存
    lstrcpy ByVal lpMem, ByVal textToCopy
    
    ' 将全局内存的内容设置到剪贴板
    SetClipboardData CF_TEXT, hMem
    
    ' 解锁和关闭剪贴板
    GlobalUnlock hMem
    CloseClipboard
    
    CopyTextToClipboard = True
End Function

Private Sub auto_open()
    Dim clsGT As New GetInfo
    Dim clsMD5 As New MD5
    Dim currRegisterCode As String
    Dim Confusion1 As String, Confusion2 As String
    Dim appName As String
    Dim confusionText As String
    Dim confusionCode As String
    Dim finalCode As String
    Confusion1 = "qWerTyuIop"
    appName = clsGT.GetCurrInfo("AppName")
    currRegisterCode = clsGT.GetCurrInfo("RegisterCode")
    timeLeft = clsGT.GetCurrInfo("TimesLeft")
    Confusion2 = appName
    confusionText = Confusion1 & Confusion2
    confusionCode = clsMD5.MD5(confusionText)
    currMachineCode = clsMD5.MD5(clsMD5.GetSerialNumber)
    finalCode = currMachineCode & confusionCode
    RegisterCodeShouldBe = clsMD5.MD5(finalCode)
    If RegisterCodeShouldBe = currRegisterCode Then
        Usf_Login.Show
    Else
        Usf_Reg.Show
    End If
End Sub

Sub BackTo()
    '已整理发表
    Dim Sht As Worksheet
    On Error Resume Next
    Sheets("Main").Activate
    Dim curSht As String
    ActiveSheet.Visible = xlSheetVisible
    curSht = ActiveSheet.Name
    For Each Sht In Excel.ThisWorkbook.Worksheets
        '批量隐藏
        If Sht.Name <> curSht Then
            Sht.Visible = xlSheetVeryHidden
        End If
    Next
End Sub

4、在工作簿“主程序MD5”里，类模块GetInfo，一些函数，在原来的应用中，有很多的，跟注册无关，都删除了：

Function GetCurrInfo(iField As String)
    GetCurrInfo = Application.WorksheetFunction.VLookup(iField, Sheets("settings").Range("B:C"), 2, 0)
End Function

Sub ShowAll()
    Dim Sht As Worksheet
    
    For Each Sht In ThisWorkbook.Worksheets
        If Sht.Visible <> xlSheetVisible Then
            Sht.Visible = xlSheetVisible
        End If
    Next
End Sub

Function ValRngAddress(iField As String)
    
    '根据Settings表中的项目名称，查询值位置
    Dim iRow As Integer, iCol As Integer
    iRow = Sheets("Settings").UsedRange.Rows.Count
    For Each rng In Sheets("Settings").Range("B2:B" & iRow)
        If rng.Value = iField Then
            ValRngAddress = rng.Offset(0, 1).Address
            Exit For
        End If
    Next
End Function

5、在工作簿“主程序MD5”里，类模块MD5，把MD5函数放到类模块，在工作表中就不会显示，也不能使用：

Private Const BITS_TO_A_BYTE = 8
Private Const BYTES_TO_A_WORD = 4
Private Const BITS_TO_A_WORD = 32
Private m_lOnBits(30)
Private m_l2Power(30)

Sub SetUpArrays()
    m_lOnBits(0) = CLng(1)
    m_lOnBits(1) = CLng(3)
    m_lOnBits(2) = CLng(7)
    m_lOnBits(3) = CLng(15)
    m_lOnBits(4) = CLng(31)
    m_lOnBits(5) = CLng(63)
    m_lOnBits(6) = CLng(127)
    m_lOnBits(7) = CLng(255)
    m_lOnBits(8) = CLng(511)
    m_lOnBits(9) = CLng(1023)
    m_lOnBits(10) = CLng(2047)
    m_lOnBits(11) = CLng(4095)
    m_lOnBits(12) = CLng(8191)
    m_lOnBits(13) = CLng(16383)
    m_lOnBits(14) = CLng(32767)
    m_lOnBits(15) = CLng(65535)
    m_lOnBits(16) = CLng(131071)
    m_lOnBits(17) = CLng(262143)
    m_lOnBits(18) = CLng(524287)
    m_lOnBits(19) = CLng(1048575)
    m_lOnBits(20) = CLng(2097151)
    m_lOnBits(21) = CLng(4194303)
    m_lOnBits(22) = CLng(8388607)
    m_lOnBits(23) = CLng(16777215)
    m_lOnBits(24) = CLng(33554431)
    m_lOnBits(25) = CLng(67108863)
    m_lOnBits(26) = CLng(134217727)
    m_lOnBits(27) = CLng(268435455)
    m_lOnBits(28) = CLng(536870911)
    m_lOnBits(29) = CLng(1073741823)
    m_lOnBits(30) = CLng(2147483647)
    
    m_l2Power(0) = CLng(1)
    m_l2Power(1) = CLng(2)
    m_l2Power(2) = CLng(4)
    m_l2Power(3) = CLng(8)
    m_l2Power(4) = CLng(16)
    m_l2Power(5) = CLng(32)
    m_l2Power(6) = CLng(64)
    m_l2Power(7) = CLng(128)
    m_l2Power(8) = CLng(256)
    m_l2Power(9) = CLng(512)
    m_l2Power(10) = CLng(1024)
    m_l2Power(11) = CLng(2048)
    m_l2Power(12) = CLng(4096)
    m_l2Power(13) = CLng(8192)
    m_l2Power(14) = CLng(16384)
    m_l2Power(15) = CLng(32768)
    m_l2Power(16) = CLng(65536)
    m_l2Power(17) = CLng(131072)
    m_l2Power(18) = CLng(262144)
    m_l2Power(19) = CLng(524288)
    m_l2Power(20) = CLng(1048576)
    m_l2Power(21) = CLng(2097152)
    m_l2Power(22) = CLng(4194304)
    m_l2Power(23) = CLng(8388608)
    m_l2Power(24) = CLng(16777216)
    m_l2Power(25) = CLng(33554432)
    m_l2Power(26) = CLng(67108864)
    m_l2Power(27) = CLng(134217728)
    m_l2Power(28) = CLng(268435456)
    m_l2Power(29) = CLng(536870912)
    m_l2Power(30) = CLng(1073741824)
End Sub

Private Function LShift(lValue, iShiftBits)
    If iShiftBits = 0 Then
        LShift = lValue
        Exit Function
    ElseIf iShiftBits = 31 Then
        If lValue And 1 Then
            LShift = &H80000000
        Else
            LShift = 0
        End If
        Exit Function
    ElseIf iShiftBits < 0 Or iShiftBits > 31 Then
        Err.Raise 6
    End If
    
    If (lValue And m_l2Power(31 - iShiftBits)) Then
        LShift = ((lValue And m_lOnBits(31 - (iShiftBits + 1))) * m_l2Power(iShiftBits)) Or &H80000000
    Else
        LShift = ((lValue And m_lOnBits(31 - iShiftBits)) * m_l2Power(iShiftBits))
    End If
End Function

Private Function RShift(lValue, iShiftBits)
    If iShiftBits = 0 Then
        RShift = lValue
        Exit Function
    ElseIf iShiftBits = 31 Then
        If lValue And &H80000000 Then
            RShift = 1
        Else
            RShift = 0
        End If
        Exit Function
    ElseIf iShiftBits < 0 Or iShiftBits > 31 Then
        Err.Raise 6
    End If
    
    RShift = (lValue And &H7FFFFFFE) \ m_l2Power(iShiftBits)
    
    If (lValue And &H80000000) Then
        RShift = (RShift Or (&H40000000 \ m_l2Power(iShiftBits - 1)))
    End If
End Function

Private Function RotateLeft(lValue, iShiftBits)
    RotateLeft = LShift(lValue, iShiftBits) Or RShift(lValue, (32 - iShiftBits))
End Function

Private Function AddUnsigned(lX, lY)
    Dim lX4
    Dim lY4
    Dim lX8
    Dim lY8
    Dim lResult
    
    lX8 = lX And &H80000000
    lY8 = lY And &H80000000
    lX4 = lX And &H40000000
    lY4 = lY And &H40000000
    
    lResult = (lX And &H3FFFFFFF) + (lY And &H3FFFFFFF)
    
    If lX4 And lY4 Then
        lResult = lResult Xor &H80000000 Xor lX8 Xor lY8
    ElseIf lX4 Or lY4 Then
        If lResult And &H40000000 Then
            lResult = lResult Xor &HC0000000 Xor lX8 Xor lY8
        Else
            lResult = lResult Xor &H40000000 Xor lX8 Xor lY8
        End If
    Else
        lResult = lResult Xor lX8 Xor lY8
    End If
    
    AddUnsigned = lResult
End Function

Private Function F(X, Y, z)
    F = (X And Y) Or ((Not X) And z)
End Function

Private Function G(X, Y, z)
    G = (X And z) Or (Y And (Not z))
End Function

Private Function H(X, Y, z)
    H = (X Xor Y Xor z)
End Function

Private Function I(X, Y, z)
    I = (Y Xor (X Or (Not z)))
End Function

Private Sub FF(a, b, c, d, X, s, ac)
    a = AddUnsigned(a, AddUnsigned(AddUnsigned(F(b, c, d), X), ac))
    a = RotateLeft(a, s)
    a = AddUnsigned(a, b)
End Sub

Private Sub GG(a, b, c, d, X, s, ac)
    a = AddUnsigned(a, AddUnsigned(AddUnsigned(G(b, c, d), X), ac))
    a = RotateLeft(a, s)
    a = AddUnsigned(a, b)
End Sub

Private Sub HH(a, b, c, d, X, s, ac)
    a = AddUnsigned(a, AddUnsigned(AddUnsigned(H(b, c, d), X), ac))
    a = RotateLeft(a, s)
    a = AddUnsigned(a, b)
End Sub

Private Sub II(a, b, c, d, X, s, ac)
    a = AddUnsigned(a, AddUnsigned(AddUnsigned(I(b, c, d), X), ac))
    a = RotateLeft(a, s)
    a = AddUnsigned(a, b)
End Sub

Private Function ConvertToWordArray(sMessage)
    Dim lMessageLength
    Dim lNumberOfWords
    Dim lWordArray()
    Dim lBytePosition
    Dim lByteCount
    Dim lWordCount
    
    Const MODULUS_BITS = 512
    Const CONGRUENT_BITS = 448
    
    lMessageLength = Len(sMessage)
    
    lNumberOfWords = (((lMessageLength + ((MODULUS_BITS - CONGRUENT_BITS) \ BITS_TO_A_BYTE)) \ (MODULUS_BITS \ BITS_TO_A_BYTE)) + 1) * (MODULUS_BITS \ BITS_TO_A_WORD)
    ReDim lWordArray(lNumberOfWords - 1)
    
    lBytePosition = 0
    lByteCount = 0
    Do Until lByteCount >= lMessageLength
        lWordCount = lByteCount \ BYTES_TO_A_WORD
        lBytePosition = (lByteCount Mod BYTES_TO_A_WORD) * BITS_TO_A_BYTE
        lWordArray(lWordCount) = lWordArray(lWordCount) Or LShift(Asc(Mid(sMessage, lByteCount + 1, 1)), lBytePosition)
        lByteCount = lByteCount + 1
    Loop
    
    lWordCount = lByteCount \ BYTES_TO_A_WORD
    lBytePosition = (lByteCount Mod BYTES_TO_A_WORD) * BITS_TO_A_BYTE
    
    lWordArray(lWordCount) = lWordArray(lWordCount) Or LShift(&H80, lBytePosition)
    
    lWordArray(lNumberOfWords - 2) = LShift(lMessageLength, 3)
    lWordArray(lNumberOfWords - 1) = RShift(lMessageLength, 29)
    
    ConvertToWordArray = lWordArray
End Function

Private Function WordToHex(lValue)
    Dim lByte
    Dim lCount
    
    For lCount = 0 To 3
        lByte = RShift(lValue, lCount * BITS_TO_A_BYTE) And m_lOnBits(BITS_TO_A_BYTE - 1)
        WordToHex = WordToHex & Right("0" & Hex(lByte), 2)
    Next
End Function


Function MD5(sMessage)
    
   Call SetUpArrays
    
    Dim X
    Dim k
    Dim AA
    Dim BB
    Dim CC
    Dim DD
    Dim a
    Dim b
    Dim c
    Dim d
    
    Const S11 = 7
    Const S12 = 12
    Const S13 = 17
    Const S14 = 22
    Const S21 = 5
    Const S22 = 9
    Const S23 = 14
    Const S24 = 20
    Const S31 = 4
    Const S32 = 11
    Const S33 = 16
    Const S34 = 23
    Const S41 = 6
    Const S42 = 10
    Const S43 = 15
    Const S44 = 21
    
    X = ConvertToWordArray(sMessage)
    
    a = &H67452301
    b = &HEFCDAB89
    c = &H98BADCFE
    d = &H10325476
    
    For k = 0 To UBound(X) Step 16
        AA = a
        BB = b
        CC = c
        DD = d
        
        FF a, b, c, d, X(k + 0), S11, &HD76AA478
        FF d, a, b, c, X(k + 1), S12, &HE8C7B756
        FF c, d, a, b, X(k + 2), S13, &H242070DB
        FF b, c, d, a, X(k + 3), S14, &HC1BDCEEE
        FF a, b, c, d, X(k + 4), S11, &HF57C0FAF
        FF d, a, b, c, X(k + 5), S12, &H4787C62A
        FF c, d, a, b, X(k + 6), S13, &HA8304613
        FF b, c, d, a, X(k + 7), S14, &HFD469501
        FF a, b, c, d, X(k + 8), S11, &H698098D8
        FF d, a, b, c, X(k + 9), S12, &H8B44F7AF
        FF c, d, a, b, X(k + 10), S13, &HFFFF5BB1
        FF b, c, d, a, X(k + 11), S14, &H895CD7BE
        FF a, b, c, d, X(k + 12), S11, &H6B901122
        FF d, a, b, c, X(k + 13), S12, &HFD987193
        FF c, d, a, b, X(k + 14), S13, &HA679438E
        FF b, c, d, a, X(k + 15), S14, &H49B40821
        
        GG a, b, c, d, X(k + 1), S21, &HF61E2562
        GG d, a, b, c, X(k + 6), S22, &HC040B340
        GG c, d, a, b, X(k + 11), S23, &H265E5A51
        GG b, c, d, a, X(k + 0), S24, &HE9B6C7AA
        GG a, b, c, d, X(k + 5), S21, &HD62F105D
        GG d, a, b, c, X(k + 10), S22, &H2441453
        GG c, d, a, b, X(k + 15), S23, &HD8A1E681
        GG b, c, d, a, X(k + 4), S24, &HE7D3FBC8
        GG a, b, c, d, X(k + 9), S21, &H21E1CDE6
        GG d, a, b, c, X(k + 14), S22, &HC33707D6
        GG c, d, a, b, X(k + 3), S23, &HF4D50D87
        GG b, c, d, a, X(k + 8), S24, &H455A14ED
        GG a, b, c, d, X(k + 13), S21, &HA9E3E905
        GG d, a, b, c, X(k + 2), S22, &HFCEFA3F8
        GG c, d, a, b, X(k + 7), S23, &H676F02D9
        GG b, c, d, a, X(k + 12), S24, &H8D2A4C8A
        
        HH a, b, c, d, X(k + 5), S31, &HFFFA3942
        HH d, a, b, c, X(k + 8), S32, &H8771F681
        HH c, d, a, b, X(k + 11), S33, &H6D9D6122
        HH b, c, d, a, X(k + 14), S34, &HFDE5380C
        HH a, b, c, d, X(k + 1), S31, &HA4BEEA44
        HH d, a, b, c, X(k + 4), S32, &H4BDECFA9
        HH c, d, a, b, X(k + 7), S33, &HF6BB4B60
        HH b, c, d, a, X(k + 10), S34, &HBEBFBC70
        HH a, b, c, d, X(k + 13), S31, &H289B7EC6
        HH d, a, b, c, X(k + 0), S32, &HEAA127FA
        HH c, d, a, b, X(k + 3), S33, &HD4EF3085
        HH b, c, d, a, X(k + 6), S34, &H4881D05
        HH a, b, c, d, X(k + 9), S31, &HD9D4D039
        HH d, a, b, c, X(k + 12), S32, &HE6DB99E5
        HH c, d, a, b, X(k + 15), S33, &H1FA27CF8
        HH b, c, d, a, X(k + 2), S34, &HC4AC5665
        
        II a, b, c, d, X(k + 0), S41, &HF4292244
        II d, a, b, c, X(k + 7), S42, &H432AFF97
        II c, d, a, b, X(k + 14), S43, &HAB9423A7
        II b, c, d, a, X(k + 5), S44, &HFC93A039
        II a, b, c, d, X(k + 12), S41, &H655B59C3
        II d, a, b, c, X(k + 3), S42, &H8F0CCC92
        II c, d, a, b, X(k + 10), S43, &HFFEFF47D
        II b, c, d, a, X(k + 1), S44, &H85845DD1
        II a, b, c, d, X(k + 8), S41, &H6FA87E4F
        II d, a, b, c, X(k + 15), S42, &HFE2CE6E0
        II c, d, a, b, X(k + 6), S43, &HA3014314
        II b, c, d, a, X(k + 13), S44, &H4E0811A1
        II a, b, c, d, X(k + 4), S41, &HF7537E82
        II d, a, b, c, X(k + 11), S42, &HBD3AF235
        II c, d, a, b, X(k + 2), S43, &H2AD7D2BB
        II b, c, d, a, X(k + 9), S44, &HEB86D391
        
        a = AddUnsigned(a, AA)
        b = AddUnsigned(b, BB)
        c = AddUnsigned(c, CC)
        d = AddUnsigned(d, DD)
    Next
    
    MD5 = LCase(WordToHex(a) & WordToHex(b) & WordToHex(c) & WordToHex(d))
End Function

Function GetSerialNumber() As String
    Dim wmi As Object
    Dim query As String
    Dim results As Object
    Dim item As Object
    Set wmi = GetObject("winmgmts:\\.\root\cimv2")
    query = "SELECT SerialNumber FROM Win32_BaseBoard"
    Set results = wmi.ExecQuery(query)
    For Each item In results
        GetSerialNumber = item.serialNumber
        Exit Function
    Next
    GetSerialNumber = "qWerTyuIop"
End Function

6、在工作簿“计算注册码”里，工作表Sheet1，命令按钮点击事件，调用计算注册码过程：

Private Sub CmdGetRegisterCode_Click()
    Call GetRegisterCode
End Sub

7、在工作簿“计算注册码”里，模块module_md5，计算注册码：

Private Const BITS_TO_A_BYTE = 8
Private Const BYTES_TO_A_WORD = 4
Private Const BITS_TO_A_WORD = 32
Private m_lOnBits(30)
Private m_l2Power(30)

Sub SetUpArrays()
    m_lOnBits(0) = CLng(1)
    m_lOnBits(1) = CLng(3)
    m_lOnBits(2) = CLng(7)
    m_lOnBits(3) = CLng(15)
    m_lOnBits(4) = CLng(31)
    m_lOnBits(5) = CLng(63)
    m_lOnBits(6) = CLng(127)
    m_lOnBits(7) = CLng(255)
    m_lOnBits(8) = CLng(511)
    m_lOnBits(9) = CLng(1023)
    m_lOnBits(10) = CLng(2047)
    m_lOnBits(11) = CLng(4095)
    m_lOnBits(12) = CLng(8191)
    m_lOnBits(13) = CLng(16383)
    m_lOnBits(14) = CLng(32767)
    m_lOnBits(15) = CLng(65535)
    m_lOnBits(16) = CLng(131071)
    m_lOnBits(17) = CLng(262143)
    m_lOnBits(18) = CLng(524287)
    m_lOnBits(19) = CLng(1048575)
    m_lOnBits(20) = CLng(2097151)
    m_lOnBits(21) = CLng(4194303)
    m_lOnBits(22) = CLng(8388607)
    m_lOnBits(23) = CLng(16777215)
    m_lOnBits(24) = CLng(33554431)
    m_lOnBits(25) = CLng(67108863)
    m_lOnBits(26) = CLng(134217727)
    m_lOnBits(27) = CLng(268435455)
    m_lOnBits(28) = CLng(536870911)
    m_lOnBits(29) = CLng(1073741823)
    m_lOnBits(30) = CLng(2147483647)
    
    m_l2Power(0) = CLng(1)
    m_l2Power(1) = CLng(2)
    m_l2Power(2) = CLng(4)
    m_l2Power(3) = CLng(8)
    m_l2Power(4) = CLng(16)
    m_l2Power(5) = CLng(32)
    m_l2Power(6) = CLng(64)
    m_l2Power(7) = CLng(128)
    m_l2Power(8) = CLng(256)
    m_l2Power(9) = CLng(512)
    m_l2Power(10) = CLng(1024)
    m_l2Power(11) = CLng(2048)
    m_l2Power(12) = CLng(4096)
    m_l2Power(13) = CLng(8192)
    m_l2Power(14) = CLng(16384)
    m_l2Power(15) = CLng(32768)
    m_l2Power(16) = CLng(65536)
    m_l2Power(17) = CLng(131072)
    m_l2Power(18) = CLng(262144)
    m_l2Power(19) = CLng(524288)
    m_l2Power(20) = CLng(1048576)
    m_l2Power(21) = CLng(2097152)
    m_l2Power(22) = CLng(4194304)
    m_l2Power(23) = CLng(8388608)
    m_l2Power(24) = CLng(16777216)
    m_l2Power(25) = CLng(33554432)
    m_l2Power(26) = CLng(67108864)
    m_l2Power(27) = CLng(134217728)
    m_l2Power(28) = CLng(268435456)
    m_l2Power(29) = CLng(536870912)
    m_l2Power(30) = CLng(1073741824)
End Sub

Private Function LShift(lValue, iShiftBits)
    If iShiftBits = 0 Then
        LShift = lValue
        Exit Function
    ElseIf iShiftBits = 31 Then
        If lValue And 1 Then
            LShift = &H80000000
        Else
            LShift = 0
        End If
        Exit Function
    ElseIf iShiftBits < 0 Or iShiftBits > 31 Then
        Err.Raise 6
    End If
    
    If (lValue And m_l2Power(31 - iShiftBits)) Then
        LShift = ((lValue And m_lOnBits(31 - (iShiftBits + 1))) * m_l2Power(iShiftBits)) Or &H80000000
    Else
        LShift = ((lValue And m_lOnBits(31 - iShiftBits)) * m_l2Power(iShiftBits))
    End If
End Function

Private Function RShift(lValue, iShiftBits)
    If iShiftBits = 0 Then
        RShift = lValue
        Exit Function
    ElseIf iShiftBits = 31 Then
        If lValue And &H80000000 Then
            RShift = 1
        Else
            RShift = 0
        End If
        Exit Function
    ElseIf iShiftBits < 0 Or iShiftBits > 31 Then
        Err.Raise 6
    End If
    
    RShift = (lValue And &H7FFFFFFE) \ m_l2Power(iShiftBits)
    
    If (lValue And &H80000000) Then
        RShift = (RShift Or (&H40000000 \ m_l2Power(iShiftBits - 1)))
    End If
End Function

Private Function RotateLeft(lValue, iShiftBits)
    RotateLeft = LShift(lValue, iShiftBits) Or RShift(lValue, (32 - iShiftBits))
End Function

Private Function AddUnsigned(lX, lY)
    Dim lX4
    Dim lY4
    Dim lX8
    Dim lY8
    Dim lResult
    
    lX8 = lX And &H80000000
    lY8 = lY And &H80000000
    lX4 = lX And &H40000000
    lY4 = lY And &H40000000
    
    lResult = (lX And &H3FFFFFFF) + (lY And &H3FFFFFFF)
    
    If lX4 And lY4 Then
        lResult = lResult Xor &H80000000 Xor lX8 Xor lY8
    ElseIf lX4 Or lY4 Then
        If lResult And &H40000000 Then
            lResult = lResult Xor &HC0000000 Xor lX8 Xor lY8
        Else
            lResult = lResult Xor &H40000000 Xor lX8 Xor lY8
        End If
    Else
        lResult = lResult Xor lX8 Xor lY8
    End If
    
    AddUnsigned = lResult
End Function

Private Function F(x, y, z)
    F = (x And y) Or ((Not x) And z)
End Function

Private Function G(x, y, z)
    G = (x And z) Or (y And (Not z))
End Function

Private Function H(x, y, z)
    H = (x Xor y Xor z)
End Function

Private Function i(x, y, z)
    i = (y Xor (x Or (Not z)))
End Function

Private Sub FF(a, b, c, d, x, s, ac)
    a = AddUnsigned(a, AddUnsigned(AddUnsigned(F(b, c, d), x), ac))
    a = RotateLeft(a, s)
    a = AddUnsigned(a, b)
End Sub

Private Sub GG(a, b, c, d, x, s, ac)
    a = AddUnsigned(a, AddUnsigned(AddUnsigned(G(b, c, d), x), ac))
    a = RotateLeft(a, s)
    a = AddUnsigned(a, b)
End Sub

Private Sub HH(a, b, c, d, x, s, ac)
    a = AddUnsigned(a, AddUnsigned(AddUnsigned(H(b, c, d), x), ac))
    a = RotateLeft(a, s)
    a = AddUnsigned(a, b)
End Sub

Private Sub II(a, b, c, d, x, s, ac)
    a = AddUnsigned(a, AddUnsigned(AddUnsigned(i(b, c, d), x), ac))
    a = RotateLeft(a, s)
    a = AddUnsigned(a, b)
End Sub

Private Function ConvertToWordArray(sMessage)
    Dim lMessageLength
    Dim lNumberOfWords
    Dim lWordArray()
    Dim lBytePosition
    Dim lByteCount
    Dim lWordCount
    
    Const MODULUS_BITS = 512
    Const CONGRUENT_BITS = 448
    
    lMessageLength = Len(sMessage)
    
    lNumberOfWords = (((lMessageLength + ((MODULUS_BITS - CONGRUENT_BITS) \ BITS_TO_A_BYTE)) \ (MODULUS_BITS \ BITS_TO_A_BYTE)) + 1) * (MODULUS_BITS \ BITS_TO_A_WORD)
    ReDim lWordArray(lNumberOfWords - 1)
    
    lBytePosition = 0
    lByteCount = 0
    Do Until lByteCount >= lMessageLength
        lWordCount = lByteCount \ BYTES_TO_A_WORD
        lBytePosition = (lByteCount Mod BYTES_TO_A_WORD) * BITS_TO_A_BYTE
        lWordArray(lWordCount) = lWordArray(lWordCount) Or LShift(Asc(Mid(sMessage, lByteCount + 1, 1)), lBytePosition)
        lByteCount = lByteCount + 1
    Loop
    
    lWordCount = lByteCount \ BYTES_TO_A_WORD
    lBytePosition = (lByteCount Mod BYTES_TO_A_WORD) * BITS_TO_A_BYTE
    
    lWordArray(lWordCount) = lWordArray(lWordCount) Or LShift(&H80, lBytePosition)
    
    lWordArray(lNumberOfWords - 2) = LShift(lMessageLength, 3)
    lWordArray(lNumberOfWords - 1) = RShift(lMessageLength, 29)
    
    ConvertToWordArray = lWordArray
End Function

Private Function WordToHex(lValue)
    Dim lByte
    Dim lCount
    
    For lCount = 0 To 3
        lByte = RShift(lValue, lCount * BITS_TO_A_BYTE) And m_lOnBits(BITS_TO_A_BYTE - 1)
        WordToHex = WordToHex & Right("0" & Hex(lByte), 2)
    Next
End Function

Public Function MD5(sMessage)
    
    module_md5.SetUpArrays
    
    Dim x
    Dim k
    Dim AA
    Dim BB
    Dim CC
    Dim DD
    Dim a
    Dim b
    Dim c
    Dim d
    
    Const S11 = 7
    Const S12 = 12
    Const S13 = 17
    Const S14 = 22
    Const S21 = 5
    Const S22 = 9
    Const S23 = 14
    Const S24 = 20
    Const S31 = 4
    Const S32 = 11
    Const S33 = 16
    Const S34 = 23
    Const S41 = 6
    Const S42 = 10
    Const S43 = 15
    Const S44 = 21
    
    x = ConvertToWordArray(sMessage)
    
    a = &H67452301
    b = &HEFCDAB89
    c = &H98BADCFE
    d = &H10325476
    
    For k = 0 To UBound(x) Step 16
        AA = a
        BB = b
        CC = c
        DD = d
        
        FF a, b, c, d, x(k + 0), S11, &HD76AA478
        FF d, a, b, c, x(k + 1), S12, &HE8C7B756
        FF c, d, a, b, x(k + 2), S13, &H242070DB
        FF b, c, d, a, x(k + 3), S14, &HC1BDCEEE
        FF a, b, c, d, x(k + 4), S11, &HF57C0FAF
        FF d, a, b, c, x(k + 5), S12, &H4787C62A
        FF c, d, a, b, x(k + 6), S13, &HA8304613
        FF b, c, d, a, x(k + 7), S14, &HFD469501
        FF a, b, c, d, x(k + 8), S11, &H698098D8
        FF d, a, b, c, x(k + 9), S12, &H8B44F7AF
        FF c, d, a, b, x(k + 10), S13, &HFFFF5BB1
        FF b, c, d, a, x(k + 11), S14, &H895CD7BE
        FF a, b, c, d, x(k + 12), S11, &H6B901122
        FF d, a, b, c, x(k + 13), S12, &HFD987193
        FF c, d, a, b, x(k + 14), S13, &HA679438E
        FF b, c, d, a, x(k + 15), S14, &H49B40821
        
        GG a, b, c, d, x(k + 1), S21, &HF61E2562
        GG d, a, b, c, x(k + 6), S22, &HC040B340
        GG c, d, a, b, x(k + 11), S23, &H265E5A51
        GG b, c, d, a, x(k + 0), S24, &HE9B6C7AA
        GG a, b, c, d, x(k + 5), S21, &HD62F105D
        GG d, a, b, c, x(k + 10), S22, &H2441453
        GG c, d, a, b, x(k + 15), S23, &HD8A1E681
        GG b, c, d, a, x(k + 4), S24, &HE7D3FBC8
        GG a, b, c, d, x(k + 9), S21, &H21E1CDE6
        GG d, a, b, c, x(k + 14), S22, &HC33707D6
        GG c, d, a, b, x(k + 3), S23, &HF4D50D87
        GG b, c, d, a, x(k + 8), S24, &H455A14ED
        GG a, b, c, d, x(k + 13), S21, &HA9E3E905
        GG d, a, b, c, x(k + 2), S22, &HFCEFA3F8
        GG c, d, a, b, x(k + 7), S23, &H676F02D9
        GG b, c, d, a, x(k + 12), S24, &H8D2A4C8A
        
        HH a, b, c, d, x(k + 5), S31, &HFFFA3942
        HH d, a, b, c, x(k + 8), S32, &H8771F681
        HH c, d, a, b, x(k + 11), S33, &H6D9D6122
        HH b, c, d, a, x(k + 14), S34, &HFDE5380C
        HH a, b, c, d, x(k + 1), S31, &HA4BEEA44
        HH d, a, b, c, x(k + 4), S32, &H4BDECFA9
        HH c, d, a, b, x(k + 7), S33, &HF6BB4B60
        HH b, c, d, a, x(k + 10), S34, &HBEBFBC70
        HH a, b, c, d, x(k + 13), S31, &H289B7EC6
        HH d, a, b, c, x(k + 0), S32, &HEAA127FA
        HH c, d, a, b, x(k + 3), S33, &HD4EF3085
        HH b, c, d, a, x(k + 6), S34, &H4881D05
        HH a, b, c, d, x(k + 9), S31, &HD9D4D039
        HH d, a, b, c, x(k + 12), S32, &HE6DB99E5
        HH c, d, a, b, x(k + 15), S33, &H1FA27CF8
        HH b, c, d, a, x(k + 2), S34, &HC4AC5665
        
        II a, b, c, d, x(k + 0), S41, &HF4292244
        II d, a, b, c, x(k + 7), S42, &H432AFF97
        II c, d, a, b, x(k + 14), S43, &HAB9423A7
        II b, c, d, a, x(k + 5), S44, &HFC93A039
        II a, b, c, d, x(k + 12), S41, &H655B59C3
        II d, a, b, c, x(k + 3), S42, &H8F0CCC92
        II c, d, a, b, x(k + 10), S43, &HFFEFF47D
        II b, c, d, a, x(k + 1), S44, &H85845DD1
        II a, b, c, d, x(k + 8), S41, &H6FA87E4F
        II d, a, b, c, x(k + 15), S42, &HFE2CE6E0
        II c, d, a, b, x(k + 6), S43, &HA3014314
        II b, c, d, a, x(k + 13), S44, &H4E0811A1
        II a, b, c, d, x(k + 4), S41, &HF7537E82
        II d, a, b, c, x(k + 11), S42, &HBD3AF235
        II c, d, a, b, x(k + 2), S43, &H2AD7D2BB
        II b, c, d, a, x(k + 9), S44, &HEB86D391
        
        a = AddUnsigned(a, AA)
        b = AddUnsigned(b, BB)
        c = AddUnsigned(c, CC)
        d = AddUnsigned(d, DD)
    Next
    
    MD5 = LCase(WordToHex(a) & WordToHex(b) & WordToHex(c) & WordToHex(d))
End Function

Sub GetRegisterCode()
    Dim MachineCode As String
    Dim finalCode As String
    Dim ConfusionText As String
    Dim ConfusionCode As String
    Dim RegisterCode As String
    Dim ws As Worksheet, i As Integer
    Dim lastRow As Integer
    Set ws = ThisWorkbook.Sheets("Sheet1")
    lastRow = ws.UsedRange.Rows.Count
    For i = 2 To lastRow
        If Cells(i, 5) <> "" And Cells(i, 7) = "" Then
            ConfusionText = Cells(i, 3).Value
            ConfusionCode = MD5(ConfusionText)
            Cells(i, 4) = ConfusionCode
            MachineCode = Cells(i, 5)
            finalCode = MachineCode & ConfusionCode
            Cells(i, 6) = finalCode
            RegisterCode = MD5(finalCode)
            Cells(i, 7) = RegisterCode
        End If
    Next
End Sub

技术交流，软件开发，欢迎微信沟通：