SHA1加密算法(40位支持中文)VB6.0实例

SHA1加密算法（40位支持中文）VB6.0实例：

Ｆorm1窗体及代码如下：

Option Explicit

Private Sub Command1_Click()

Text2.Text = StringSHA1(Text1.Text)

End Sub

通用模块代码如下：

'--------------------------------------------------------------------------------------------------------------------------

'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 '

https://www.360docs.net/doc/f52553899.html,/xq/ASP/txtCodeId.13565/lngWId.1/qx/vb/scripts/ShowCode.ht m

' 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:

' https://www.360docs.net/doc/f52553899.html,/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 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 < 0 Then DMod = DMod + divisor

End Function

Private 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 Function

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)), 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