VB6对字符串或文件取得SHA1值源码

　　将以下代码保存为SHA1.BAS文件，加入你的工程就可以使用了。VB代码的SHA1算法执行速度很慢。 Attribute VB_Name = "SHA1 " Option Explicit ' TITLE: ' Secure Hash Algorithm, SHA-1 ' AUTHORS: ' Adapted by Iain Buchan from Visual Basic code posted at Planet-Source-Code by Peter Girard ' http://www.planetsourcecode.com/xq/ASP/txtCodeId.1 3565/lngWId.1/qx/vb/scripts/ShowCode.htm ' PURPOSE: ' Creating a secure identifier from person-identifiable data ' The function SecureHash generates a 160-bit (20-hex-digit) message digest for a given message (String). ' It is computationally infeasable to recover the message from the digest. ' The digest is unique to the message within the realms of practical probability. ' The only way to find the source message for a digest is by hashing all possible messages and comparison of their digests. ' REFERENCES: ' For a fuller description see FIPS Publication 180-1: ' http://www.itl.nist.gov/fipspubs/fip180-1.htm ' SAMPLE: ' Message: "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnom nopnopq " ' Returns Digest: "84983E441C3BD26EBAAE4AA1F95129E5E54670F1 " ' Message: "abc " ' Returns Digest: "A9993E364706816ABA3E25717850C26C9CD0D89D " Private Type Word B0 As Byte B1 As Byte B2 As Byte B3 As Byte End Type 'Public Function idcode(cr As Range) As String ' Dim tx As String ' Dim ob As Object ' For Each ob In cr ' tx = tx & LCase(CStr(ob.Value2)) ' Next ' idcode = sha1(tx) 'End Function Private Function AndW(w1 As Word, w2 As Word) As Word AndW.B0 = w1.B0 And w2.B0 AndW.B1 = w1.B1 And w2.B1 AndW.B2 = w1.B2 And w2.B2 AndW.B3 = w1.B3 And w2.B3 End Function Private Function OrW(w1 As Word, w2 As Word) As Word OrW.B0 = w1.B0 Or w2.B0 OrW.B1 = w1.B1 Or w2.B1 OrW.B2 = w1.B2 Or w2.B2 OrW.B3 = w1.B3 Or w2.B3 End Function Private Function XorW(w1 As Word, w2 As Word) As Word XorW.B0 = w1.B0 Xor w2.B0 XorW.B1 = w1.B1 Xor w2.B1 XorW.B2 = w1.B2 Xor w2.B2 XorW.B3 = w1.B3 Xor w2.B3 End Function Private Function NotW(w As Word) As Word NotW.B0 = Not w.B0 NotW.B1 = Not w.B1 NotW.B2 = Not w.B2 NotW.B3 = Not w.B3 End Function Private Function AddW(w1 As Word, w2 As Word) As Word Dim i As Long, w As Word i = CLng(w1.B3) + w2.B3 w.B3 = i Mod 256 i = CLng(w1.B2) + w2.B2 + (i \ 256) w.B2 = i Mod 256 i = CLng(w1.B1) + w2.B1 + (i \ 256) w.B1 = i Mod 256 i = CLng(w1.B0) + w2.B0 + (i \ 256) w.B0 = i Mod 256 AddW = w End Function Private Function CircShiftLeftW(w As Word, n As Long) As Word Dim d1 As Double, d2 As Double d1 = WordToDouble(w) d2 = d1 d1 = d1 * (2 ^ n) d2 = d2 / (2 ^ (32 - n)) CircShiftLeftW = OrW(DoubleToWord(d1), DoubleToWord(d2)) End Function Private Function WordToHex(w As Word) As String WordToHex = Right$( "0 " & Hex$(w.B0), 2) & Right$( "0 " & Hex$(w.B1), 2) _ & Right$( "0 " & Hex$(w.B2), 2) & Right$( "0 " & Hex$(w.B3), 2) End Function Private Function HexToWord(H As String) As Word HexToWord = DoubleToWord(Val( "&H " & H & "# ")) End Function Private Function DoubleToWord(n As Double) As Word DoubleToWord.B0 = Int(DMod(n, 2 ^ 32) / (2 ^ 24)) DoubleToWord.B1 = Int(DMod(n, 2 ^ 24) / (2 ^ 16)) DoubleToWord.B2 = Int(DMod(n, 2 ^ 16) / (2 ^ 8)) DoubleToWord.B3 = Int(DMod(n, 2 ^ 8)) End Function Private Function WordToDouble(w As Word) As Double WordToDouble = (w.B0 * (2 ^ 24)) + (w.B1 * (2 ^ 16)) + (w.B2 * (2 ^ 8)) _ + w.B3 End Function Private Function DMod(value As Double, divisor As Double) As Double DMod = value - (Int(value / divisor) * divisor) If DMod 字符串的SHA1摘要 Dim inLen As Long Dim inLenW As Word Dim padMessage As String Dim numBlocks As Long Dim w(0 To 79) As Word Dim blockText As String Dim wordText As String Dim i As Long, t As Long Dim temp As Word Dim K(0 To 3) As Word Dim H0 As Word Dim H1 As Word Dim H2 As Word Dim H3 As Word Dim H4 As Word Dim A As Word Dim B As Word Dim C As Word Dim D As Word Dim E As Word inMessage = StrConv(inMessage, vbFromUnicode) inLen = LenB(inMessage) inLenW = DoubleToWord(CDbl(inLen) * 8) padMessage = inMessage & ChrB(128) _ & StrConv(String((128 - (inLen Mod 64) - 9) Mod 64 + 4, Chr(0)), 128) _ & ChrB(inLenW.B0) & ChrB(inLenW.B1) & ChrB(inLenW.B2) & ChrB(inLenW.B3) numBlocks = LenB(padMessage) / 64 ' initialize constants K(0) = HexToWord( "5A827999 ") K(1) = HexToWord( "6ED9EBA1 ") K(2) = HexToWord( "8F1BBCDC ") K(3) = HexToWord( "CA62C1D6 ") ' initialize 160-bit (5 words) buffer H0 = HexToWord( "67452301 ") H1 = HexToWord( "EFCDAB89 ") H2 = HexToWord( "98BADCFE ") H3 = HexToWord( "10325476 ") H4 = HexToWord( "C3D2E1F0 ") ' each 512 byte message block consists of 16 words (W) but W is expanded For i = 0 To numBlocks - 1 blockText = MidB$(padMessage, (i * 64) + 1, 64) ' initialize a message block For t = 0 To 15 wordText = MidB$(blockText, (t * 4) + 1, 4) w(t).B0 = AscB(MidB$(wordText, 1, 1)) w(t).B1 = AscB(MidB$(wordText, 2, 1)) w(t).B2 = AscB(MidB$(wordText, 3, 1)) w(t).B3 = AscB(MidB$(wordText, 4, 1)) Next ' create extra words from the message block For t = 16 To 79 ' W(t) = S^1 (W(t-3) XOR W(t-8) XOR W(t-14) XOR W(t-16)) w(t) = CircShiftLeftW(XorW(XorW(XorW(w(t - 3), w(t - 8)), _ w(t - 14)), w(t - 16)), 1) Next ' make initial assignments to the buffer A = H0 B = H1 C = H2 D = H3 E = H4 ' process the block For t = 0 To 79 temp = AddW(AddW(AddW(AddW(CircShiftLeftW(A, 5), _ F(t, B, C, D)), E), w(t)), K(t \ 20)) E = D D = C C = CircShiftLeftW(B, 30) B = A A = temp Next H0 = AddW(H0, A) H1 = AddW(H1, B) H2 = AddW(H2, C) H3 = AddW(H3, D) H4 = AddW(H4, E) Next StringSHA1 = WordToHex(H0) & WordToHex(H1) & WordToHex(H2) _ & WordToHex(H3) & WordToHex(H4) End Function Public Function SHA1(inMessage() As Byte) As String ' 计算字节数组的SHA1摘要 Dim inLen As Long Dim inLenW As Word Dim numBlocks As Long Dim w(0 To 79) As Word Dim blockText As String Dim wordText As String Dim t As Long Dim temp As Word Dim K(0 To 3) As Word Dim H0 As Word Dim H1 As Word Dim H2 As Word Dim H3 As Word Dim H4 As Word Dim A As Word Dim B As Word Dim C As Word Dim D As Word Dim E As Word Dim i As Long Dim lngPos As Long Dim lngPadMessageLen As Long Dim padMessage() As Byte inLen = UBound(inMessage) + 1 inLenW = DoubleToWord(CDbl(inLen) * 8) lngPadMessageLen = inLen + 1 + (128 - (inLen Mod 64) - 9) Mod 64 + 8 ReDim padMessage(lngPadMessageLen - 1) As Byte For i = 0 To inLen - 1 padMessage(i) = inMessage(i) Next i padMessage(inLen) = 128 padMessage(lngPadMessageLen - 4) = inLenW.B0 padMessage(lngPadMessageLen - 3) = inLenW.B1 padMessage(lngPadMessageLen - 2) = inLenW.B2 padMessage(lngPadMessageLen - 1) = inLenW.B3 numBlocks = lngPadMessageLen / 64 ' initialize constants K(0) = HexToWord( "5A827999 ") K(1) = HexToWord( "6ED9EBA1 ") K(2) = HexToWord( "8F1BBCDC ") K(3) = HexToWord( "CA62C1D6 ") ' initialize 160-bit (5 words) buffer H0 = HexToWord( "67452301 ") H1 = HexToWord( "EFCDAB89 ") H2 = HexToWord( "98BADCFE ") H3 = HexToWord( "10325476 ") H4 = HexToWord( "C3D2E1F0 ") ' each 512 byte message block consists of 16 words (W) but W is expanded ' to 80 words For i = 0 To numBlocks - 1 ' initialize a message block For t = 0 To 15 w(t).B0 = padMessage(lngPos) w(t).B1 = padMessage(lngPos + 1) w(t).B2 = padMessage(lngPos + 2) w(t).B3 = padMessage(lngPos + 3) lngPos = lngPos + 4 Next ' create extra words from the message block For t = 16 To 79 ' W(t) = S^1 (W(t-3) XOR W(t-8) XOR W(t-14) XOR W(t-16)) w(t) = CircShiftLeftW(XorW(XorW(XorW(w(t - 3), w(t - 8)), _ w(t - 14)), w(t - 16)), 1) Next ' make initial assignments to the buffer A = H0 B = H1 C = H2 D = H3 E = H4 ' process the block For t = 0 To 79 temp = AddW(AddW(AddW(AddW(CircShiftLeftW(A, 5), _ F(t, B, C, D)), E), w(t)), K(t \ 20)) E = D D = C C = CircShiftLeftW(B, 30) B = A A = temp Next H0 = AddW(H0, A) H1 = AddW(H1, B) H2 = AddW(H2, C) H3 = AddW(H3, D) H4 = AddW(H4, E) Next SHA1 = WordToHex(H0) & WordToHex(H1) & WordToHex(H2) _ & WordToHex(H3) & WordToHex(H4) End Function Public Function FileSHA1(strFilename As String) As String ' 计算文件的SHA1摘要 Dim lngFileNo As Long Dim bytData() As Byte If Dir(strFilename) = " " Then GoTo PROC_EXIT End If lngFileNo = FreeFile On Error GoTo PROC_ERR ' 打开文件 Open strFilename For Binary As lngFileNo ' 读取文件内容 ReDim bytData(LOF(lngFileNo) - 1) As Byte Get #lngFileNo, 1, bytData ' 关闭文件 Close lngFileNo ' 计算文件的SHA1摘要 FileSHA1 = SHA1(bytData) PROC_EXIT: Erase bytData Exit Function PROC_ERR: Close GoTo PROC_EXIT End Function 另从Wikia中收集了一个精简的类，但我没测试过。 原文如下：
　　An implementation of the SHA-1 hash algorithm. First version, might still contain bugs.
　　Function HexDefaultSHA1(Message() As Byte) As String Returns the SHA-1 hash of Message using the default key as a string of hexadecimal numbers. Function HexSHA1(Message() As Byte, ByVal Key1 As Long, ByVal Key2 As Long, ByVal Key3 As Long, ByVal Key4 As Long) As String Returns the SHA-1 hash of Message using the key specified by Key1 ... Key4 as a string of hexadecimal numbers. Sub DefaultSHA1(Message() As Byte, H1 As Long, H2 As Long, H3 As Long, H4 As Long, H5 As Long) Returns the SHA-1 hash of Message using the default key in H1 ... H5. Sub SHA1(Message() As Byte, ByVal Key1 As Long, ByVal Key2 As Long, ByVal Key3 As Long, ByVal Key4 As Long, H1 As Long, H2 As Long, H3 As Long, H4 As Long, H5 As Long) Returns the SHA-1 hash of Message using the key specified by Key1 ... Key4 in H1 ... H5. This module was originally written as a replacement for a similar module by John Taylor. However, this module should be more efficient, and it uses Byte arrays instead of strings for the message, which makes it suitable for digesting binary data, or text containing international characters. Note that if you coerce a String into a Byte array, Visual Basic will copy the actual data bytes of the string, which is stored as a sequence of 16 bit Unicode character codes. That means that every character takes two bytes. If this doesn't suit your needs, you'll have to convert the string yourself, for example using the StrConv function. It's just a straightforward implementation of SHA-1. Since only creative works are copyrightable, this code is in the public domain. 译： 这是一个SHA -1散列算法的实现。第一个版本，可能包含错误。
　　Function HexDefaultSHA1(... ...)
　　该函数返回一个十六进制数字的字符串作为默认的SHA1哈希值密钥。
　　Function HexSHA1(... ...)
　　使用指定的Key1....Key4字符串做为一个六进制数字字符串进行返回
　　Sub DefaultSHA1(... ...)
　　用默认的关键值H1...H5做为哈希值进行返回
　　这个模块最初是由John Taylor. However编写提供。这个模块应该更可高效，他只能用于字节数组而不是字符串，这可以处理二进制数据或带包含国际字符的文件。
　　注意：如果你强制使一个字符串转到字节数组时，VB将复制字符串的实际数据字节，它存储为一个16位的Unicode字符代码序列,这意味着，每个字符需要两个字节。如果这不能满足您的需要，你就必须将自己的字符串进行转换，例如使用StrConv函数。
　　授权
　　这是一个SHA-1的功能简单实现。只保留著作权，此代码可以在公开领域使用。 'Attribute VB_Name = "SHA1vb" Option Explicit Private Type FourBytes A As Byte B As Byte C As Byte D As Byte End Type Private Type OneLong L As Long End Type Function HexDefaultSHA1(Message() As Byte) As String Dim H1 As Long, H2 As Long, H3 As Long, H4 As Long, H5 As Long DefaultSHA1 Message, H1, H2, H3, H4, H5 HexDefaultSHA1 = DecToHex5(H1, H2, H3, H4, H5) End Function Function HexSHA1(Message() As Byte, ByVal Key1 As Long, ByVal Key2 As Long, ByVal Key3 As Long, ByVal Key4 As Long) As String Dim H1 As Long, H2 As Long, H3 As Long, H4 As Long, H5 As Long SHA1 Message, Key1, Key2, Key3, Key4, H1, H2, H3, H4, H5 HexSHA1 = DecToHex5(H1, H2, H3, H4, H5) End Function Sub DefaultSHA1(Message() As Byte, H1 As Long, H2 As Long, H3 As Long, H4 As Long, H5 As Long) SHA1 Message, &H5A827999, &H6ED9EBA1, &H8F1BBCDC, &HCA62C1D6, H1, H2, H3, H4, H5 End Sub Sub SHA1(Message() As Byte, ByVal Key1 As Long, ByVal Key2 As Long, ByVal Key3 As Long, ByVal Key4 As Long, H1 As Long, H2 As Long, H3 As Long, H4 As Long, H5 As Long) 'CA62C1D68F1BBCDC6ED9EBA15A827999 + "abc" = "A9993E36 4706816A BA3E2571 7850C26C 9CD0D89D" '"abc" = "A9993E36 4706816A BA3E2571 7850C26C 9CD0D89D" Dim U As Long, P As Long Dim FB As FourBytes, OL As OneLong Dim I As Integer Dim W(80) As Long Dim A As Long, B As Long, C As Long, D As Long, E As Long Dim T As Long H1 = &H67452301: H2 = &HEFCDAB89: H3 = &H98BADCFE: H4 = &H10325476: H5 = &HC3D2E1F0 U = UBound(Message) + 1: OL.L = U32ShiftLeft3(U): A = U \ &H20000000: LSet FB = OL 'U32ShiftRight29(U) ReDim Preserve Message(0 To (U + 8 And -64) + 63) Message(U) = 128 U = UBound(Message) Message(U - 4) = A Message(U - 3) = FB.D Message(U - 2) = FB.C Message(U - 1) = FB.B Message(U) = FB.A While P < U For I = 0 To 15 FB.D = Message(P) FB.C = Message(P + 1) FB.B = Message(P + 2) FB.A = Message(P + 3) LSet OL = FB W(I) = OL.L P = P + 4 Next I For I = 16 To 79 W(I) = U32RotateLeft1(W(I - 3) Xor W(I - 8) Xor W(I - 14) Xor W(I - 16)) Next I A = H1: B = H2: C = H3: D = H4: E = H5 For I = 0 To 19 T = U32Add(U32Add(U32Add(U32Add(U32RotateLeft5(A), E), W(I)), Key1), ((B And C) Or ((Not B) And D))) E = D: D = C: C = U32RotateLeft30(B): B = A: A = T Next I For I = 20 To 39 T = U32Add(U32Add(U32Add(U32Add(U32RotateLeft5(A), E), W(I)), Key2), (B Xor C Xor D)) E = D: D = C: C = U32RotateLeft30(B): B = A: A = T Next I For I = 40 To 59 T = U32Add(U32Add(U32Add(U32Add(U32RotateLeft5(A), E), W(I)), Key3), ((B And C) Or (B And D) Or (C And D))) E = D: D = C: C = U32RotateLeft30(B): B = A: A = T Next I For I = 60 To 79 T = U32Add(U32Add(U32Add(U32Add(U32RotateLeft5(A), E), W(I)), Key4), (B Xor C Xor D)) E = D: D = C: C = U32RotateLeft30(B): B = A: A = T Next I H1 = U32Add(H1, A): H2 = U32Add(H2, B): H3 = U32Add(H3, C): H4 = U32Add(H4, D): H5 = U32Add(H5, E) Wend End Sub Function U32Add(ByVal A As Long, ByVal B As Long) As Long If (A Xor B) < 0 Then U32Add = A + B Else U32Add = (A Xor &H80000000) + B Xor &H80000000 End If End Function Function U32ShiftLeft3(ByVal A As Long) As Long U32ShiftLeft3 = (A And &HFFFFFFF) * 8 If A And &H10000000 Then U32ShiftLeft3 = U32ShiftLeft3 Or &H80000000 End Function Function U32ShiftRight29(ByVal A As Long) As Long U32ShiftRight29 = (A And &HE0000000) \ &H20000000 And 7 End Function Function U32RotateLeft1(ByVal A As Long) As Long U32RotateLeft1 = (A And &H3FFFFFFF) * 2 If A And &H40000000 Then U32RotateLeft1 = U32RotateLeft1 Or &H80000000 If A And &H80000000 Then U32RotateLeft1 = U32RotateLeft1 Or 1 End Function Function U32RotateLeft5(ByVal A As Long) As Long U32RotateLeft5 = (A And &H3FFFFFF) * 32 Or (A And &HF8000000) \ &H8000000 And 31 If A And &H4000000 Then U32RotateLeft5 = U32RotateLeft5 Or &H80000000 End Function Function U32RotateLeft30(ByVal A As Long) As Long U32RotateLeft30 = (A And 1) * &H40000000 Or (A And &HFFFC) \ 4 And &H3FFFFFFF If A And 2 Then U32RotateLeft30 = U32RotateLeft30 Or &H80000000 End Function Function DecToHex5(ByVal H1 As Long, ByVal H2 As Long, ByVal H3 As Long, ByVal H4 As Long, ByVal H5 As Long) As String Dim H As String, L As Long DecToHex5 = "00000000 00000000 00000000 00000000 00000000" H = Hex(H1): L = Len(H): Mid(DecToHex5, 9 - L, L) = H H = Hex(H2): L = Len(H): Mid(DecToHex5, 18 - L, L) = H H = Hex(H3): L = Len(H): Mid(DecToHex5, 27 - L, L) = H H = Hex(H4): L = Len(H): Mid(DecToHex5, 36 - L, L) = H H = Hex(H5): L = Len(H): Mid(DecToHex5, 45 - L, L) = H End Function