Public Function sha1(keydata As String, message As String) As String '//////////////////////////////////////////////////////////////////////////////////////////////////////////// 'dependencies ' 'i32shiftleft 'i32shiftright 'i32rotateleft 'i32add 'hextodec 'dectohex '//////////////////////////////////////////////////////////////////////////////////////////////////////////// 'keydata is 4 x int32 ascii hex string, if null the default key will be used (msb at left) 'message is raw binary, unpadded 'return data is 5 x int32 ascii hex string with space between each int32 (msb at left) ' ' 'Hash initialization data 'Index Data '0 0x67452301 '1 0xEFCDAB89 '2 0x98BADCFE '3 0x10325476 '4 0xC3D2E1F0 ' ' 'Default key 'Index Key Rounds '0 0x5A827999 0 <= i <= 19 LSB '1 0x6ED9EBA1 20 <= i <= 39 '2 0x8F1BBCDC 40 <= i <= 59 '3 0xCA62C1D6 60 <= i <= 79 MSB ' ' 'these calls would be the equivalent of using the default key as shown in the spec 'userhash = sha1("CA62C1D68F1BBCDC6ED9EBA15A827999","abc") = "A9993E36 4706816A BA3E2571 7850C26C 9CD0D89D" 'userhash = sha1("","abc") = "A9993E36 4706816A BA3E2571 7850C26C 9CD0D89D" '/////////////////////////////////////////////////////////////////////////////////////////////////////////// Dim k(4) As Long 'key constants defined in SHA1 spec '---------------------------------------------------------------------------- Dim mcounter As Long 'external block(m) loop counter '---------------------------------------------------------------------------- Dim messagesize As Long 'size in bits of original message (Pre-pad) Dim padsize As Integer 'used to determine how many zeros to pad Dim chunk As String '64 byte chunk of message, as a string Dim messageblock(64) As Byte 'block buffer, translated to w(0) to w(15) Dim bcounter As Integer 'block parser loop counter '---------------------------------------------------------------------------- Dim t As Integer 'internal word(t) loop counter Dim w(80) As Long 'word sequence, w(16) to w(79) are prehashed Dim a As Long 'Word buffers for working block Dim b As Long Dim c As Long Dim d As Long Dim e As Long Dim runninghash(5) As Long 'updated from a...e after each block Dim temp As Long 'temporary word value '---------------------------------------------------------------------------- Dim hashtext As String 'output builder for ascii hex result Dim hcounter As Integer 'build loop counter '---------------------------------------------------------------------------- Dim hexin As String 'cleaned up key data Dim i As Integer 'cleanup counter '/////////////////////////////////////////////////////////////////////////////////////////////////////////// 'mode control If keydata = "" Then 'use default key from SHA1 spec k(0) = &H5A827999 k(1) = &H6ED9EBA1 k(2) = &H8F1BBCDC k(3) = &HCA62C1D6 Else 'use key passed to function 'front pad with zeros 'strip out all non hex characters For i = 1 To Len(keydata) Select Case Mid(keydata, i, 1) Case "0" To "9", "a" To "f", "A" To "F" hexin = hexin + Mid(keydata, i, 1) End Select Next i hexin = Right(String(32, "0") + hexin, 32) k(0) = hextodec(Mid(hexin, 25, 8)) k(1) = hextodec(Mid(hexin, 17, 8)) k(2) = hextodec(Mid(hexin, 9, 8)) k(3) = hextodec(Mid(hexin, 1, 8)) End If 'initialize hash data for this message runninghash(0) = &H67452301 runninghash(1) = &HEFCDAB89 runninghash(2) = &H98BADCFE runninghash(3) = &H10325476 runninghash(4) = &HC3D2E1F0 '///////////////////////////////////////////////////////////////////////////////////////////////////////// 'pad message to 1 to n 512 bit blocks 'save length of original message in bits (Bytes * 8), but use shift function to avoid vb overflow messagesize = i32shiftleft(Len(message), 3) 'append a '1' bit to the end of the message (this is actually a '1' with 7 '0's!) message = message + Chr(&H80) 'pad with zeros to make mod(64)-8 bytes padsize = (64 - ((Len(message) + 8) Mod 64)) And 63 message = message + String(padsize, Chr(0)) 'the last 8 bytes is the count of message bits, or bytes x 8 'this is only (32bits/8bitsperbyte)= 536,870,911 bytes cause I suck message = message + Chr(0) message = message + Chr(0) message = message + Chr(0) message = message + Chr(0) message = message + Chr(i32shiftright(messagesize, 24) And 255) message = message + Chr(i32shiftright(messagesize, 16) And 255) message = message + Chr(i32shiftright(messagesize, 8) And 255) message = message + Chr(messagesize And 255) '///////////////////////////////////////////////////////////////////////////////////////////////////////// 'do hash in 64 byte blocks (512 bits) For mcounter = Int(Len(message) / 64) To 1 Step -1 '//////////////////////////////////////////////////////////////////////////////////////////////////////// chunk = Mid(message, ((Int(Len(message) / 64) - mcounter) * 64) + 1, 64) 'parse out 64 bytes into 16 32 bit words For bcounter = 0 To 63 messageblock(bcounter) = Asc(Mid(chunk, bcounter + 1, 1)) Next bcounter 'convert byte data in message block to 32int in first 16 w words For t = 0 To 15 w(t) = i32shiftleft(CLng(messageblock(t * 4)), 24) w(t) = w(t) Or i32shiftleft(CLng(messageblock(t * 4 + 1)), 16) w(t) = w(t) Or i32shiftleft(CLng(messageblock(t * 4 + 2)), 8) w(t) = w(t) Or CLng(messageblock(t * 4 + 3)) Next t 'pre-hash w(0) to w(15) into w(16) to w(79) For t = 16 To 79 w(t) = i32rotateleft(w(t - 3) Xor w(t - 8) Xor w(t - 14) Xor w(t - 16), 1) Next t 'initialize counters for this block from running hash for whole message a = runninghash(0) b = runninghash(1) c = runninghash(2) d = runninghash(3) e = runninghash(4) 'do the actual hash For t = 0 To 79 Select Case t Case 0 To 19 temp = i32add(i32add(i32add(i32add(i32rotateleft(a, 5), e), w(t)), k(0)), ((b And c) Or ((Not b) And d))) Case 20 To 39 temp = i32add(i32add(i32add(i32add(i32rotateleft(a, 5), e), w(t)), k(1)), (b Xor c Xor d)) Case 40 To 59 temp = i32add(i32add(i32add(i32add(i32rotateleft(a, 5), e), w(t)), k(2)), ((b And c) Or (b And d) Or (c And d))) Case 60 To 79 temp = i32add(i32add(i32add(i32add(i32rotateleft(a, 5), e), w(t)), k(3)), (b Xor c Xor d)) End Select e = d d = c c = i32rotateleft(b, 30) b = a a = temp Next t 'update running hash with results for this block runninghash(0) = i32add(runninghash(0), a) runninghash(1) = i32add(runninghash(1), b) runninghash(2) = i32add(runninghash(2), c) runninghash(3) = i32add(runninghash(3), d) runninghash(4) = i32add(runninghash(4), e) '///////////////////////////////////////////////////////////////////////////////////////////////////////// Next mcounter '///////////////////////////////////////////////////////////////////////////////////////////////////////// 'return result of hash as 5 ascii hex words hashtext = dectohex(runninghash(0), 8) For hcounter = 1 To 4 hashtext = hashtext + " " + dectohex(runninghash(hcounter), 8) Next hcounter sha1 = hashtext '//////////////////////////////////////////////////////////////////////////////////////////////////////// End Function Public Function i32add(operanda As Long, operandb As Long) As Long '////////////////////////////////////////////////////////////////////////////////////// 'does 32 bit add of two 32 bit numbers as if they were unsigned int32's 'this has to be done this way because of quirk in VB where an add overflow 'into the sign bit is kicked out as an error. This would not be a problem if 'an unsigned int32 were allowed in VB! ' 'result=operanda + operandb ' 'use this function for (a+b) ' 'Not, And, Or, Xor all work the same for signed and unsigned int32 because there are 'no carries or borrows for VB to deal with '////////////////////////////////////////////////////////////////////////////////////// Dim operand_ax As Long Dim operand_bx As Long Dim upper_a As Integer Dim upper_b As Integer Dim result As Long Dim topbits As Integer '////////////////////////////////////////////////////////////////////////////////////// 'trim off offending bits operand_ax = operanda And &H3FFFFFFF operand_bx = operandb And &H3FFFFFFF upper_a = ((operanda And &HC0000000) / &H40000000) And 3 upper_b = ((operandb And &HC0000000) / &H40000000) And 3 'do math on lower order bits result = operand_ax + operand_bx 'do math on upper order bits topbits = upper_a + upper_b 'if there was an overflow into upper 2 bits, increment the accumulator If result And &H40000000 Then topbits = topbits + 1 End If 'get rid of an overflow into upper 2 bits in lieu of separate math below result = result And &H3FFFFFFF 'now adjust the upper bits for the side calculation results If topbits And 1 Then result = result Or &H40000000 End If If topbits And 2 Then result = result Or &H80000000 End If i32add = result End Function Public Function i32sub(operanda As Long, operandb As Long) As Long '////////////////////////////////////////////////////////////////////////////////////// 'does 32 bit subtract of two 32 bit numbers as if they were unsigned int32's 'this has to be done this way because of quirk in VB where an add overflow 'into the sign bit is kicked out as an error. This would not be a problem if 'an unsigned int32 were allowed in VB! ' 'result=operanda - operandb ' 'use this function for (a-b) ' 'Not, And, Or, Xor all work the same for signed and unsigned int32 because there are 'no carries or borrows for VB to deal with '////////////////////////////////////////////////////////////////////////////////////// i32sub = i32add(i32add(operanda, Not operandb), 1) End Function Public Function i32rotateleft(datain As Long, bitcount As Integer) '////////////////////////////////////////////////////////////////////////// 'does a left rotate on a signed integer as if it were unsigned ' (MSB) < MSB.....LSB < (MSB) ' 'for i=0 to 32:print dectohex(i32rotateleft(&h0000000f,int(i)),8):next i '////////////////////////////////////////////////////////////////////////// Dim msb As Integer Dim msb_m1 As Integer Dim i As Integer Dim xdatain As Long '////////////////////////////////////////////////////////////////////////// xdatain = datain If (bitcount >= 32) Or (bitcount <= 0) Then i32rotateleft = datain Exit Function End If For i = 1 To bitcount 'get msb If xdatain And &H80000000 Then msb = 1 Else msb = 0 End If 'get msb-1 bit If xdatain And &H40000000 Then msb_m1 = 1 Else msb_m1 = 0 End If xdatain = (xdatain And &H3FFFFFFF) * 2 If msb Then xdatain = xdatain Or 1 End If If msb_m1 Then xdatain = xdatain Or &H80000000 End If Next i i32rotateleft = xdatain End Function Public Function i32rotateright(datain As Long, bitcount As Integer) As Long '////////////////////////////////////////////////////////////////////////// 'does a right rotate on a signed integer as if it were unsigned ' (LSB) > MSB.....LSB > (LSB) ' 'for i=0 to 32:print dectohex(i32rotateright(&hf0000000,int(i)),8):next i '////////////////////////////////////////////////////////////////////////// Dim lsb As Integer Dim i As Integer Dim xdatain As Long '////////////////////////////////////////////////////////////////////////// xdatain = datain If (bitcount >= 32) Or (bitcount <= 0) Then i32rotateright = datain Exit Function End If For i = 1 To bitcount 'get lsb If xdatain And 1 Then lsb = 1 Else lsb = 0 End If xdatain = Int(xdatain / 2) And &H7FFFFFFF 'without the "INT()", its really broken! If lsb Then xdatain = xdatain Or &H80000000 End If Next i i32rotateright = xdatain End Function Public Function i32shiftleft(datain As Long, bitcount As Integer) As Long '////////////////////////////////////////////////////////////////////////// 'does a left shift on a signed integer as if it were unsigned ' MSB.....LSB < (0) ' 'for i=0 to 32:print dectohex(i32shiftleft(&hffffffff,int(i)),8):next i '////////////////////////////////////////////////////////////////////////// Dim msb_m1 As Integer Dim i As Integer Dim xdatain As Long '////////////////////////////////////////////////////////////////////////// xdatain = datain If (bitcount <= 0) Then i32shiftleft = datain Exit Function End If If (bitcount >= 32) Then i32shiftleft = 0 Exit Function End If For i = 1 To bitcount 'get msb-1 bit If xdatain And &H40000000 Then msb_m1 = 1 Else msb_m1 = 0 End If xdatain = (xdatain And &H3FFFFFFF) * 2 If msb_m1 Then xdatain = xdatain Or &H80000000 End If Next i i32shiftleft = xdatain End Function Public Function i32shiftright(datain As Long, bitcount As Integer) '////////////////////////////////////////////////////////////////////////// 'does a right shift on a signed integer as if it were unsigned ' (0) > MSB.....LSB ' 'for i=0 to 32:print dectohex(i32shiftright(&hffffffff,int(i)),8):next i '////////////////////////////////////////////////////////////////////////// Dim i As Integer Dim xdatain As Long '////////////////////////////////////////////////////////////////////////// xdatain = datain If (bitcount <= 0) Then i32shiftright = datain Exit Function End If If (bitcount >= 32) Then i32shiftright = 0 Exit Function End If For i = 1 To bitcount xdatain = Int(xdatain / 2) And &H7FFFFFFF 'without the "INT()", its really broken! Next i i32shiftright = xdatain End Function Public Function dectohex(datain As Long, hexdigits As Integer) As String '///////////////////////////////////////////////////////////////////////////////////////// 'converts 32 bit signed integer to hex string of n hex digits 'since datain is specified here as long, -1 gets converted with hex() to "FFFFFFFF" 'if you just type it in at the immediate window hex() would convert -1 to "FFFF" because 'only a 16bit integer would be assumed! '///////////////////////////////////////////////////////////////////////////////////////// Dim i As Integer Dim outdata As String '///////////////////////////////////////////////////////////////////////////////////////// If hexdigits > 8 Then hexdigits = 8 End If outdata = Right(Right("00000000" + Hex(datain), 8), hexdigits) dectohex = outdata End Function Public Function hextodec(datain As String) As Long '///////////////////////////////////////////////////////////////////////////////// 'converts up to 8 character hexadecimal to 32 bit signed integer 'non hex characters are stripped out '///////////////////////////////////////////////////////////////////////////////// Dim hexin As String Dim lhex As Integer Dim result As Long Dim i As Integer Dim hexdata As String Dim decdata As Long Dim invert As Boolean '///////////////////////////////////////////////////////////////////////////////// 'strip out all non hex characters For i = 1 To Len(datain) Select Case Mid(datain, i, 1) Case "0" To "9", "a" To "f", "A" To "F" hexin = hexin + Mid(datain, i, 1) End Select Next i 'trim off more than 8 characters hexin = Right(hexin, 8) If Len(hexin) = 8 Then Select Case Left(hexin, 1) Case "0" To "7" 'do nothing since VB can handle this! invert = False Case Else 'post process result to get sign in there! 'trim to 31 bits, do sign bit later 'only slightly recursive! Mid(hexin, 1, 1) = Hex(hextodec(Left(hexin, 1)) - 8) invert = True End Select End If hexin = UCase(hexin) lhex = Len(hexin) result = 0 For i = 1 To lhex hexdata = Mid(hexin, lhex - i + 1, 1) Select Case hexdata Case "0" To "9" decdata = 16 ^ (i - 1) * Val(hexdata) Case "A" To "F" decdata = 16 ^ (i - 1) * (Asc(hexdata) - 55) End Select result = result + decdata Next i If invert = False Then hextodec = result Else hextodec = result - &H7FFFFFFF - 1 End If End Function Public Function hextobin(datain As String) As String '///////////////////////////////////////////////////////////////////////////////// 'converts ascii hex block to raw binary (1 byte per 2 characters) string '///////////////////////////////////////////////////////////////////////////////// Dim hexin As String Dim i As Integer Dim outdata As String '///////////////////////////////////////////////////////////////////////////////// 'strip out all non hex characters For i = 1 To Len(datain) Select Case Mid(datain, i, 1) Case "0" To "9", "a" To "f", "A" To "F" hexin = hexin + Mid(datain, i, 1) End Select Next i 'ensure even number of ascii hex characters If Len(hexin) Mod 2 Then hexin = "0" + hexin End If For i = 1 To Len(hexin) - 1 Step 2 outdata = outdata + Chr(hextodec(Mid(hexin, i, 2))) Next i hextobin = outdata End Function Public Function sha1hex(keydata As String, datain As String) As String '////////////////////////////////////////////////////////////////////////// 'this is needed by excel because it does not accept null characters 'in raw binary strings so this has to all be done at module level 'without passing interrim result back to spreadsheet (Which truncates the 'string at the first null) '////////////////////////////////////////////////////////////////////////// sha1hex = sha1(keydata, hextobin(datain)) End Function