内容提要
-
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
技术交流，软件开发，欢迎微信沟通：
扫一扫
733
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
