请问有没有SHA-1算法的源代码或是DLL

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.13565/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: "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq"
' Returns Digest: "84983E441C3BD26EBAAE4AA1F95129E5E54670F1"
' Message: "abc"
' Returns Digest: "A9993E364706816ABA3E25717850C26C9CD0D89D"Private Type Word
B0 As Byte
B1 As Byte
B2 As Byte
B3 As Byte
End TypePublic 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 FunctionPrivate 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 FunctionPrivate 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 FunctionPrivate 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 FunctionPrivate 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 FunctionPrivate 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 FunctionPrivate 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 FunctionPrivate Function HexToWord(H As String) As Word
HexToWord = DoubleToWord(Val("&H" & H & "#"))
End FunctionPrivate 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 FunctionPrivate Function WordToDouble(w As Word) As Double
WordToDouble = (w.B0 * (2 ^ 24)) + (w.B1 * (2 ^ 16)) + (w.B2 * (2 ^ 8)) + w.B3
End FunctionPrivate Function DMod(value As Double, divisor As Double) As Double
DMod = value - (Int(value / divisor) * divisor)
If DMod < 0 Then DMod = DMod + divisor
End FunctionPrivate Function F(t As Long, B As Word, C As Word, D As Word) As Word
Select Case t
Case Is <= 19
  F = OrW(AndW(B, C), AndW(NotW(B), D))
Case Is <= 39
  F = XorW(XorW(B, C), D)
Case Is <= 59
  F = OrW(OrW(AndW(B, C), AndW(B, D)), AndW(C, D))
Case Else
  F = XorW(XorW(B, C), D)
End Select
End FunctionPublic Function sha1(inMessage As String) As StringDim inLen As Long, inLenW As Word, padMessage As String, numBlocks As Long, w(0 To 79) As Word, blockText As String, wordText As String, I As Long, t As Long, temp As Word, K(0 To 3) As Word, H0 As Word, H1 As Word, H2 As Word, H3 As Word, H4 As Word, A As Word, B As Word, C As Word, D As Word, E As WordinLen = Len(inMessage)
inLenW = DoubleToWord(CDbl(inLen) * 8)

padMessage = inMessage & Chr$(128) & String$((128 - (inLen Mod 64) - 9) Mod 64, Chr$(0)) & String$(4, Chr$(0)) & Chr$(inLenW.B0) & Chr$(inLenW.B1) & Chr$(inLenW.B2) & Chr$(inLenW.B3)

numBlocks = Len(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 to 80 words
For I = 0 To numBlocks - 1
blockText = Mid$(padMessage, (I * 64) + 1, 64)
'initialize a message block
For t = 0 To 15
  wordText = Mid$(blockText, (t * 4) + 1, 4)
  w(t).B0 = Asc(Mid$(wordText, 1, 1))
  w(t).B1 = Asc(Mid$(wordText, 2, 1))
  w(t).B2 = Asc(Mid$(wordText, 3, 1))
  w(t).B3 = Asc(Mid$(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)
Nextsha1 = WordToHex(H0) & WordToHex(H1) & WordToHex(H2) & WordToHex(H3) & WordToHex(H4)End Function

楼上代码不完整吧
//Public Function idcode(cr As Range) As String
用户定义类行未定义

idcode这个函数是一个批量处理数据的，把该函数整个注释掉就能够正常运行了。主调用函数为Public Function sha1(inMessage As String) As String调用举例：
Debug.Print sha1("abc")输出：
A9993E364706816ABA3E25717850C26C9CD0D89Dsha-1的RFC文档在http://www.faqs.org/rfcs/rfc3174.html可以查看。

改了一下chewinggum贴的代码，可以支持中文了，另外增加了计算字节数组Byte()和文件SHA1码的两个函数，已用fsum软件测试通过，计算结果是正确的，不过速度很慢，几十大K的文件要几秒钟才能算出SHA1摘要码来，这套VB代码只适合少量数据的计算。注：前部省略的代码与chewinggum贴的代码一致，原sha1函数被替换为StringSHA1函数。
Public Function StringSHA1(inMessage As String) As String
    ' 计算字符串的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)), vbFromUnicode) & 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 to 80 words
    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 FunctionPublic 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 FunctionPublic 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

    FileSHA1 = SHA1(bytData)

PROC_EXIT:
    Erase bytData
    Exit Function

PROC_ERR:
    Close
    GoTo PROC_EXIT

End Function

调试易

请问有没有SHA-1算法的源代码或是DLL

解决方案 »