' VB Script conversion by Richard Briggs : Richard.briggs@LeanSoftware.net ' All credits to the original authors who originally coded this in VB as denoted within the code Option Explicit Private Const OFFSET_4 = 4294967296'# Private Const MAXINT_4 = 2147483647 Private State'(4) 'As Long Private ByteCounter 'As Long Private ByteBuffer()'(63) 'As Byte Private Const S11 = 7 Private Const S12 = 12 Private Const S13 = 17 Private Const S14 = 22 Private Const S21 = 5 Private Const S22 = 9 Private Const S23 = 14 Private Const S24 = 20 Private Const S31 = 4 Private Const S32 = 11 Private Const S33 = 16 Private Const S34 = 23 Private Const S41 = 6 Private Const S42 = 10 Private Const S43 = 15 Private Const S44 = 21 Set args = WScript.Arguments ' force State variable to datatype double State = Array(cdbl(1),cdbl(1),cdbl(1),cdbl(1),cdbl(1)) ' force bytebuffer() to datatype Byte for i = 1 to 64 redim preserve ByteBuffer(i) 'As Byte ByteBuffer(i) = cbyte(0) next ' Get command line parameters Dim Email, App, args,ans,i Email = args.Item(0) App = args.Item(1) ' Generate the key code ans = FormatKeyCode(GenKeyString(Email,App, 0),5) Wscript.Echo ans ' * ' * KeyCodeGen Module ' * Copyright (C) 2007 John Mazza. ' * ' * Written by John Mazza ' * ' * This library is free software; you can redistribute it and/or ' * modify it under the terms of the GNU Lesser General Public ' * License Version 2.1 as published by the Free Software Foundation. ' * ' * This library is distributed in the hope that it will be useful, ' * but WITHOUT ANY WARRANTY; without even the implied warranty of ' * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ' * Lesser General Public License for more details. ' * ' * You should have received a copy of the GNU Lesser General Public ' * License along with this library; if not, write to the Free Software ' * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ' **************************************************************************** ' ' ' PURPOSE ' Generate a licening key code that encodes product features into the ' "keycode" string securely. ' ' LANGUAGE ' Visual Basic 6.0 or VBA6 ' Should work in VB.NET as well ' ' DEPENDENCIES: ' Requires 'Visual Basic MD5 Implementation' by ' Robert Hubley and David Midkiff (mdj2023@hotmail.com) and ' StrFuncs module by John Mazza ' ' GenKeyString() generates the actual keycode string based on ' modified MD5 hashes of Username, Product, and licensed "features" Public Function GenKeyString(ByVal UserName, ProdName , F_Code ) 'As String Dim TempStr 'As String Dim KeyStr 'As String Dim KeyVal 'As String Dim CodeVal 'As Long Dim CodeLow 'As Byte Dim CodeHigh 'As Byte Dim KeyLowV1 'As Byte Dim KeyLowV2 'As Byte Dim KeyLow1 Dim KeyLow2 Dim ChrV1 Dim ChrV2 ' Make sure we're not case-sensitive since that is a pain for end users TempStr = LCase(UserName) & LCase(ProdName) KeyStr = DigestStrToHexStr(TempStr) KeyVal = HexStrToBinStr(KeyStr) ' Mask off low order 16 bits from F_Code CodeVal = F_Code And &HFFFF CodeLow = CodeVal And &HFF CodeHigh = (((CodeVal And &HFF00) / 256) And &HFF) KeyLow1 = Mid(KeyVal, Len(KeyVal), 1) KeyLow2 = Mid(KeyVal, Len(KeyVal) - 1, 1) KeyLowV1 = Asc(KeyLow1) KeyLowV2 = Asc(KeyLow2) KeyLowV1 = (KeyLowV1 Xor CodeLow) KeyLowV2 = (KeyLowV2 Xor CodeHigh) 'KeyLowV1 = KeyLowV1 Xor KeyLowV2 ChrV1 = Chr(KeyLowV1) ChrV2 = Chr(KeyLowV2) ' Cut original first 2 bytes from KeyVal string KeyVal = Mid(KeyVal, 1, Len(KeyVal) - 2) ' Now append modified bytes KeyVal = KeyVal & ChrV2 & ChrV1 'KeyVal = KeyVal & ChrV1 ' Now we get sneaky and modify the KeyVal by replacing the first 2 bytes ' of KeyVal with the first and last bytes of the MD5 of KeyVal minus first 2 bytes KeyVal = Mid(KeyVal, 3, Len(KeyVal) - 2) dim RawChk RawChk = DigestStrToHexStr(KeyVal) dim rc1, rc2 RC1 = Mid(RawChk, 1, 2) RC2 = Mid(RawChk, Len(RawChk) - 1, 2) dim StubStr StubStr = BinStrToHexStr(KeyVal) GenKeyString = RC1 & RC2 & StubStr End Function ' ValidateKeyCode() validates that a keycode is valid. ' Basically it is the inverse of GenKeyString() Public Function ValidateKeyCode(ByVal KeyCode, UserName, ProjName )' As Boolean Dim ActiveBytes 'As String Dim LUNameHash 'As String Dim LUName 'As String Dim ValidKey 'As Boolean Dim KeyMD5 'As String Dim KeySig 'As String ValidKey = False ' Key must be 32 bytes long - otherwise reject immediately If Len(KeyCode) = 32 Then BinKeyCode = HexStrToBinStr(KeyCode) ActiveBytes = Right(BinKeyCode, 14) KeyMD5 = DigestStrToHexStr(ActiveBytes) ValidSig = Left(KeyMD5, 2) & Right(KeyMD5, 2) KeySig = Left(KeyCode, 4) If KeySig = ValidSig Then ValidKey = True Else ValidKey = False End If If ValidKey Then LUName = LCase(UserName) & LCase(ProjName) LUNameHash = DigestStrToHexStr(LUName) ActiveBytes = Mid(KeyCode, 5, 24) LUNameHash = Mid(LUNameHash, 5, 24) If ActiveBytes = LUNameHash Then ValidKey = True Else ValidKey = False End If End If Else ValidKey = False End If ValidateKeyCode = ValidKey End Function ' ExtractKeyFBits() returns the bitmap originally passed as F_Code ' when a key is created with GenKeyString() ' Note: it will return zero (0) if an invalid keycode is passed or if ' username or projectname are not a match. Public Function ExtractKeyFBits(ByVal KeyCode, UserName, ProjName ) Dim PermVal 'As Long Dim RealHash 'As String Dim LUser 'As String Dim Perms 'As Long Dim BinCodePerm 'As String Dim BinUHashPerm 'As String Dim HiCodePerm 'As Byte Dim HIUMask 'As Byte Dim LoUMask 'As Byte Dim HiPerm 'As Long Dim LoPerm 'As Long PermVal = 0 If ValidateKeyCode(KeyCode, UserName, ProjName) Then LUser = LCase(UserName) & LCase(ProjName) UserHash = DigestStrToHexStr(LUser) KCodedPerm = Right(KeyCode, 4) UHashPerm = Right(UserHash, 4) BinCodePerm = HexStrToBinStr(KCodedPerm) BinUHashPerm = HexStrToBinStr(UHashPerm) HiCodePerm = Asc(Mid(BinCodePerm, 1, 1)) LoCodePerm = Asc(Mid(BinCodePerm, 2, 1)) HIUMask = Asc(Mid(BinUHashPerm, 1, 1)) LoUMask = Asc(Mid(BinUHashPerm, 2, 1)) HiPerm = HiCodePerm Xor HIUMask LoPerm = LoCodePerm Xor LoUMask PermVal = (HiPerm * 256) Or LoPerm Else PermVal = 0 End If ExtractKeyFBits = PermVal End Function Public Function FormatKeyCode(ByVal StrIn , ByVal GrpLen ) Dim StrLen 'As Long Dim CurGrp 'As Long Dim OutStr 'As String Dim GrpStr 'As String Dim GrpStart 'As Long StrLen = Len(StrIn) dim strGroups, StrLeftOver strGroups = Int(StrLen / GrpLen) StrLeftOver = StrLen Mod GrpLen ' Run loop to add dashes into StrIn For CurGrp = 0 To (strGroups - 1) GrpStart = (CurGrp * GrpLen) + 1 GrpStr = Mid(StrIn, GrpStart, GrpLen) If CurGrp > 0 Then OutStr = OutStr & "-" & GrpStr Else OutStr = OutStr & GrpStr End If Next 'CurGrp ' Append a final group if any leftover charaters ' exist in StrIn If StrLeftOver > 0 Then OutStr = OutStr & "-" & Right(StrIn, StrLeftOver) End If FormatKeyCode = OutStr End Function ' * ' * StrFuncs Module ' * Copyright (C) 2007 John Mazza. ' * ' * Written by John Mazza ' * ' * This library is free software; you can redistribute it and/or ' * modify it under the terms of the GNU Lesser General Public ' * License Version 2.1 as published by the Free Software Foundation. ' * ' * This library is distributed in the hope that it will be useful, ' * but WITHOUT ANY WARRANTY; without even the implied warranty of ' * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ' * Lesser General Public License for more details. ' * ' * You should have received a copy of the GNU Lesser General Public ' * License along with this library; if not, write to the Free Software ' * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ' **************************************************************************** ' ' PURPOSE ' String manipulation routines ' ' LANGUAGE ' Visual Basic 6.0 or VBA6 ' Should work in VB.NET as well ' ' DEPENDENCIES: ' None known ' ' Helper for Base32 numbers Const B32Map = "0123456789ABCDEFGHJKLMNPRSTVWXYZ" ' General String Functions ' RemoveDashes() - Trivial function to delete "-" character from a string Public Function RemoveDashes(ByVal StrIn ) 'As String RemoveDashes = Replace(StrIn, "-", "") End Function ' ShiftStrLeft() - Shift a string left by a number of bits Public Function ShiftStrLeft(ByVal StrIn , ByVal Bits )' As String Dim CurPos 'As Long Dim WorkStr 'As String Dim RetStr 'As String Dim CurByteVal 'As Byte Dim BitMask 'As Byte Dim InvMask 'As Byte Dim ShiftBits 'As Byte Dim WholeBytes 'As Long Dim LeftPart 'As Byte Dim RightPart 'As Byte Dim Carry 'As Byte Dim PrevChar 'As Byte Dim TrimMask 'As Byte ' Figure out some metrics on our input string WholeBytes = Int(Bits / 8) ShiftBits = Bits Mod 8 BitMask = 255 - (2 ^ (8 - ShiftBits) - 1) InvMask = Not (BitMask) TrimMask = (2 ^ ShiftBits) - 1 CurPos = 1 StrLen = Len(StrIn) StrBits = StrLen * 8 WorkStr = StrIn ' Check we're not trying to shift more bits than ' we have in the string. If (StrBits > Bits) Then ' First, shift string by whole bytes If (WholeBytes > 0) Then WorkStr = Right(WorkStr, StrLen - WholeBytes) ' Pad zero bytes to end of WorkStr to make length match For CurPos = 1 To WholeBytes WorkStr = WorkStr & Chr(0) Next 'CurPos ' Ensure RetStr contains shifted string in case no other ' bitwise shifting is performed later RetStr = WorkStr End If ' Now handle the bitwise shift If (ShiftBits > 0) Then For CurPos = 1 To Len(WorkStr) ' Read next character of input and mask it appropriately CurByteVal = Asc(Mid(WorkStr, CurPos, 1)) LeftPart = (CurByteVal And BitMask) And &HFF RightPart = (CurByteVal And InvMask) And &HFF ' Shift the masked portions LeftPart = Int(LeftPart / (2 ^ (8 - ShiftBits))) RightPart = (RightPart * (2 ^ ShiftBits)) If CurPos = 1 Then ' Put the non-discarded part into PrevChar for later use PrevChar = (RightPart) RetStr = "" Else ' Put carryover part into PrevChar and combine ' the other bits with the carry from previous step PrevChar = PrevChar Or LeftPart RetStr = RetStr & Chr(PrevChar) PrevChar = RightPart End If Next 'CurPos ' Combine our final carry with last char of string and mask off PrevChar = (PrevChar Or (LeftPart And Not (TrimMask))) RetStr = RetStr & Chr(PrevChar) End If Else ' If we're trying to shift by more bits than ' input string, return an equal length string ' full of zeroes (null characters). For CurPos = 1 To StrLen RetStr = RetStr & Chr(0) Next 'CurPos End If ShiftStrLeft = RetStr End Function ' ShiftStringRight() - Shift a string right a number of bits Public Function ShiftStrRight(ByVal StrIn , ByVal Bits )' As String Dim CurPos 'As Long Dim WorkStr 'As String Dim RetStr 'As String Dim CurByteVal 'As Byte Dim BitMask 'As Byte Dim InvMask 'As Byte Dim ShiftBits 'As Byte Dim WholeBytes 'As Long Dim LeftPart 'As Byte Dim RightPart 'As Byte Dim Carry 'As Byte Dim PrevChar 'As Byte Dim TrimMask 'As Byte ' Calculate metrics on input WholeBytes = Int(Bits / 8) ShiftBits = Bits Mod 8 BitMask = 255 - ((2 ^ ShiftBits) - 1) InvMask = Not (BitMask) TrimMask = (2 ^ ShiftBits) - 1 CurPos = 1 StrLen = Len(StrIn) StrBits = StrLen * 8 ' Check we're not trying to shift more bits than ' we have in the string. WorkStr = StrIn If (StrBits > Bits) Then ' First, shift string by whole bytes If (WholeBytes > 0) Then WorkStr = Left(WorkStr, StrLen - WholeBytes) ' Pad zero bytes to end of WorkStr For CurPos = 1 To WholeBytes WorkStr = Chr(0) & WorkStr Next' CurPos ' Ensure RetStr contains shifted string in case no other ' bitwise shifting later RetStr = WorkStr End If ' Now handle the bitwise shift If (ShiftBits > 0) Then RetStr = "" For CurPos = Len(WorkStr) To 1 Step -1 CurByteVal = Asc(Mid(WorkStr, CurPos, 1)) LeftPart = CurByteVal And BitMask LeftPart = LeftPart / (2 ^ ShiftBits) RightPart = CurByteVal And InvMask RightPart = RightPart * (2 ^ (8 - ShiftBits)) If CurPos = Len(WorkStr) Then Carry = LeftPart Else CurByteVal = RightPart Or Carry Carry = LeftPart RetStr = Chr(CurByteVal) & RetStr End If Next 'CurPos RetStr = Chr(Carry) & RetStr End If Else ' If we're trying to shift by more bits than ' input string, return an equal length string ' full of zeroes. For CurPos = 1 To StrLen RetStr = RetStr & Chr(0) Next 'CurPos End If ShiftStrRight = RetStr End Function ' Base32Enc() - Takes a "binary" string and represents as a Base32 number ' Net result is an encoding where each "character" represents 5 bits Public Function Base32Enc(ByVal StrIn ) 'As String Dim CurBit 'As Long Dim Mask32 'As Byte Dim CurPos 'As Long Dim CurVal 'As Byte Dim StrBits 'As Long Dim BitsProc 'As Long Dim WorkStr 'As String Dim RetStr 'As String Dim CurConv 'As String RetStr = "" WorkStr = StrIn StrBits = Len(StrIn) * 8 strGroups = Int(StrBits / 5) If (StrBits Mod 5) <> 0 Then strGroups = strGroups + 1 StrChar = Len(StrIn) BitsProc = 0 Mask32 = &H1F ' Work from back of string to front. ' and output the character representing each 5-bit group For CurPos = 1 To strGroups CurVal = Asc(Mid(WorkStr, Len(WorkStr), 1)) CurVal = (CurVal And Mask32) + 1 CurConv = Mid(B32Map, CurVal, 1) WorkStr = ShiftStrRight(WorkStr, 5) RetStr = CurConv & RetStr Next 'CurPos Base32Enc = RetStr End Function ' Base32Dec() - Takes a string encoded with Base32Enc() and returns the ' original "binary" string it represents. Public Function Base32Dec(ByVal StrIn ) 'As String Dim CurPos 'As Long Dim CurVal 'As Byte Dim CurChr 'As String Dim RetStr 'As String Dim WorkStr 'As String Dim Carry 'As Byte Dim CarryMask 'As Byte Dim CurMask 'As Byte Dim ThisVal 'As Byte Dim ThisChar 'As String Dim ShiftBits 'As Long Dim OutBytes 'As Long Dim InBits 'As Long ' Calculate metrics BitsProc = 0 BaseMask = &H1F Carry = 0 WorkStr = StrIn InBits = Len(StrIn) * 5 OutBytes = Int(InBits / 8) ' Setup a string of zero bytes to push values into later For CurPos = 1 To OutBytes RetStr = RetStr & Chr(0) Next 'CurPos ' Convert input string into binary representation For CurPos = 1 To Len(StrIn) ' Derive 5-bit value of current char in StrIn CurChr = Mid(WorkStr, CurPos, 1) CurVal = InStr(1, B32Map, CurChr) CurVal = CurVal - 1 ' Now, shift RetStr left 5 bits and pop last char off RetStr = ShiftStrLeft(RetStr, 5) ThisChar = Mid(RetStr, Len(RetStr), 1) RetStr = Left(RetStr, Len(RetStr) - 1) ' Now, OR our CurChr with the popped value ' and push result back to end of string ThisVal = Asc(ThisChar) ThisVal = ThisVal Or CurVal ThisChar = Chr(ThisVal) RetStr = RetStr & ThisChar Next 'CurPos Base32Dec = RetStr End Function ' HexStrToBinStr() - Convert a hexadecimal string into a binary representation Public Function HexStrToBinStr(ByVal StrIn )' As String Dim StrOut 'As String Dim Ch 'As Long Dim HexByte 'As String Dim ByteVal 'As Long Dim ByteCh 'As String StrOut = "" For Ch = 1 To Len(StrIn) Step 2 HexByte = Mid(StrIn, Ch, 2) 'ByteVal = val("&H" & HexByte) ByteVal = cint("&H" & HexByte) ByteCh = Chr(ByteVal) StrOut = StrOut & ByteCh Next 'Ch HexStrToBinStr = StrOut End Function ' BinStrToHexStr() - Convert a binary string to a hexadecimal representation Public Function BinStrToHexStr(ByVal StrIn )' As String Dim StrOut 'As String Dim Ch 'As Long Dim HexByte 'As String Dim HexChr 'As String StrOut = "" For Ch = 1 To Len(StrIn) HexByte = Mid(StrIn, Ch, 1) 'HexChr = Hex$(Asc(HexByte)) HexChr = Hex(Asc(HexByte)) If Len(HexChr) = 1 Then HexChr = "0" & HexChr StrOut = StrOut & HexChr Next 'Ch BinStrToHexStr = StrOut End Function ' Visual Basic MD5 Implementation ' Robert Hubley and David Midkiff (mdj2023@hotmail.com) ' ' Standard MD5 implementation optimised for the Visual Basic environment. ' Conforms to all standards and can be used in digital signature or password ' protection related schemes. ' ' NOTE - JDM 5/23/2007 ' (Research indicates this code is Licensed for free use) ' Function RegisterA() 'As String RegisterA = State(1) End function 'Property Function RegisterB() 'As String RegisterB = State(2) End function 'Property Function RegisterC() 'As String RegisterC = State(3) End function 'Property Function RegisterD() 'As String RegisterD = State(4) End function 'Property Public Function DigestStrToHexStr(SourceString ) 'As String MD5Init MD5Update Len(SourceString), StringToArray(SourceString) MD5Final DigestStrToHexStr = GetValues End Function 'Public Function DigestFileToHexStr(InFile ) 'As String 'On Error GoTo errorhandler 'on error resume next 'GoSub begin 'errorhandler: ' DigestFileToHexStr = "" ' Exit Function 'begin: ' Dim FileO 'As Integer ' FileO = FreeFile ' Call FileLen(InFile) ' Open InFile For Binary Access Read As #FileO ' MD5Init ' Do While Not EOF(FileO) ' Get #FileO, , ByteBuffer ' If Loc(FileO) < LOF(FileO) Then ' ByteCounter = ByteCounter + 64 ' MD5Transform ByteBuffer ' End If ' Loop ' ByteCounter = ByteCounter + (LOF(FileO) Mod 64) ' Close #FileO ' MD5Final ' DigestFileToHexStr = GetValues 'End Function Private Function StringToArray(InString ) 'As Byte() Dim i 'As Integer dim bytBuffer() 'As Byte ReDim bytBuffer(Len(InString)) For i = 0 To Len(InString) - 1 'bytBuffer(i) = Asc(Mid$(InString, i + 1, 1)) bytBuffer(i) = Asc(Mid(InString, i + 1, 1)) Next' i StringToArray = bytBuffer End Function Public Function GetValues() 'As String GetValues = LongToString(State(1)) & LongToString(State(2)) & LongToString(State(3)) & LongToString(State(4)) End Function Private Function LongToString(Num) 'As String Dim A 'As Byte dim B 'As Byte dim C 'As Byte dim D 'As Byte A = Num And &HFF& If A < 16 Then LongToString = "0" & Hex(A) Else LongToString = Hex(A) B = (Num And &HFF00&) \ 256 If B < 16 Then LongToString = LongToString & "0" & Hex(B) Else LongToString = LongToString & Hex(B) C = (Num And &HFF0000) \ 65536 If C < 16 Then LongToString = LongToString & "0" & Hex(C) Else LongToString = LongToString & Hex(C) If Num < 0 Then D = ((Num And &H7F000000) \ 16777216) Or &H80& Else D = (Num And &HFF000000) \ 16777216 If D < 16 Then LongToString = LongToString & "0" & Hex(D) Else LongToString = LongToString & Hex(D) End Function Public Sub MD5Init() ByteCounter = 0 'State(1) = UnsignedToLong(1732584193#) 'State(2) = UnsignedToLong(4023233417#) 'State(3) = UnsignedToLong(2562383102#) 'State(4) = UnsignedToLong(271733878#) State(1) = UnsignedToLong(cDbl(1732584193)) State(2) = UnsignedToLong(cDbl(4023233417)) State(3) = UnsignedToLong(cDbl(2562383102)) State(4) = UnsignedToLong(cdbl(271733878)) End Sub Public Sub MD5Final() Dim dblBits 'As Double dim padding(72) 'As Byte dim lngBytesBuffered 'As Long padding(0) = &H80 dblBits = ByteCounter * 8 lngBytesBuffered = ByteCounter Mod 64 If lngBytesBuffered <= 56 Then MD5Update 56 - lngBytesBuffered, padding Else MD5Update 120 - ByteCounter, padding padding(0) = UnsignedToLong(dblBits) And &HFF& padding(1) = UnsignedToLong(dblBits) \ 256 And &HFF& padding(2) = UnsignedToLong(dblBits) \ 65536 And &HFF& padding(3) = UnsignedToLong(dblBits) \ 16777216 And &HFF& padding(4) = 0 padding(5) = 0 padding(6) = 0 padding(7) = 0 MD5Update 8, padding End Sub Public Sub MD5Update(InputLen , InputBuffer() ) Dim II 'As Integer, dim i 'As Integer, dim J 'As Integer, dim K 'As Integer, dim lngBufferedBytes 'As Long, dim lngBufferRemaining 'As Long, dim lngRem 'As Long lngBufferedBytes = ByteCounter Mod 64 lngBufferRemaining = 64 - lngBufferedBytes ByteCounter = ByteCounter + InputLen If InputLen >= lngBufferRemaining Then For II = 0 To lngBufferRemaining - 1 ByteBuffer(lngBufferedBytes + II) = InputBuffer(II) Next 'II MD5Transform ByteBuffer lngRem = (InputLen) Mod 64 For i = lngBufferRemaining To InputLen - II - lngRem Step 64 For J = 0 To 63 ByteBuffer(J) = InputBuffer(i + J) Next 'J MD5Transform ByteBuffer Next 'i lngBufferedBytes = 0 Else i = 0 End If For K = 0 To InputLen - i - 1 ByteBuffer(lngBufferedBytes + K) = InputBuffer(i + K) Next 'K End Sub Private Sub MD5Transform(Buffer() ) Dim X(16) 'As Long dim A 'As Long, dim B 'As Long, dim C 'As Long, dim D 'As Long A = State(1) B = State(2) C = State(3) D = State(4) Decode 64, X, Buffer FF A, B, C, D, X(0), S11, -680876936 FF D, A, B, C, X(1), S12, -389564586 FF C, D, A, B, X(2), S13, 606105819 FF B, C, D, A, X(3), S14, -1044525330 FF A, B, C, D, X(4), S11, -176418897 FF D, A, B, C, X(5), S12, 1200080426 FF C, D, A, B, X(6), S13, -1473231341 FF B, C, D, A, X(7), S14, -45705983 FF A, B, C, D, X(8), S11, 1770035416 FF D, A, B, C, X(9), S12, -1958414417 FF C, D, A, B, X(10), S13, -42063 FF B, C, D, A, X(11), S14, -1990404162 FF A, B, C, D, X(12), S11, 1804603682 FF D, A, B, C, X(13), S12, -40341101 FF C, D, A, B, X(14), S13, -1502002290 FF B, C, D, A, X(15), S14, 1236535329 GG A, B, C, D, X(1), S21, -165796510 GG D, A, B, C, X(6), S22, -1069501632 GG C, D, A, B, X(11), S23, 643717713 GG B, C, D, A, X(0), S24, -373897302 GG A, B, C, D, X(5), S21, -701558691 GG D, A, B, C, X(10), S22, 38016083 GG C, D, A, B, X(15), S23, -660478335 GG B, C, D, A, X(4), S24, -405537848 GG A, B, C, D, X(9), S21, 568446438 GG D, A, B, C, X(14), S22, -1019803690 GG C, D, A, B, X(3), S23, -187363961 GG B, C, D, A, X(8), S24, 1163531501 GG A, B, C, D, X(13), S21, -1444681467 GG D, A, B, C, X(2), S22, -51403784 GG C, D, A, B, X(7), S23, 1735328473 GG B, C, D, A, X(12), S24, -1926607734 HH A, B, C, D, X(5), S31, -378558 HH D, A, B, C, X(8), S32, -2022574463 HH C, D, A, B, X(11), S33, 1839030562 HH B, C, D, A, X(14), S34, -35309556 HH A, B, C, D, X(1), S31, -1530992060 HH D, A, B, C, X(4), S32, 1272893353 HH C, D, A, B, X(7), S33, -155497632 HH B, C, D, A, X(10), S34, -1094730640 HH A, B, C, D, X(13), S31, 681279174 HH D, A, B, C, X(0), S32, -358537222 HH C, D, A, B, X(3), S33, -722521979 HH B, C, D, A, X(6), S34, 76029189 HH A, B, C, D, X(9), S31, -640364487 HH D, A, B, C, X(12), S32, -421815835 HH C, D, A, B, X(15), S33, 530742520 HH B, C, D, A, X(2), S34, -995338651 II A, B, C, D, X(0), S41, -198630844 II D, A, B, C, X(7), S42, 1126891415 II C, D, A, B, X(14), S43, -1416354905 II B, C, D, A, X(5), S44, -57434055 II A, B, C, D, X(12), S41, 1700485571 II D, A, B, C, X(3), S42, -1894986606 II C, D, A, B, X(10), S43, -1051523 II B, C, D, A, X(1), S44, -2054922799 II A, B, C, D, X(8), S41, 1873313359 II D, A, B, C, X(15), S42, -30611744 II C, D, A, B, X(6), S43, -1560198380 II B, C, D, A, X(13), S44, 1309151649 II A, B, C, D, X(4), S41, -145523070 II D, A, B, C, X(11), S42, -1120210379 II C, D, A, B, X(2), S43, 718787259 II B, C, D, A, X(9), S44, -343485551 State(1) = LongOverflowAdd(State(1), A) State(2) = LongOverflowAdd(State(2), B) State(3) = LongOverflowAdd(State(3), C) State(4) = LongOverflowAdd(State(4), D) End Sub Private Sub Decode(Length , OutputBuffer() , InputBuffer() ) Dim intDblIndex 'As Integer, dim intByteIndex 'As Integer, dim dblSum 'As Double For intByteIndex = 0 To Length - 1 Step 4 'dblSum = InputBuffer(intByteIndex) + InputBuffer(intByteIndex + 1) * 256# + InputBuffer(intByteIndex + 2) * 65536# + InputBuffer(intByteIndex + 3) * 16777216# dblSum = InputBuffer(intByteIndex) + InputBuffer(intByteIndex + 1) * 256 + InputBuffer(intByteIndex + 2) * 65536 + InputBuffer(intByteIndex + 3) * 16777216 OutputBuffer(intDblIndex) = UnsignedToLong(dblSum) intDblIndex = intDblIndex + 1 Next' intByteIndex End Sub 'Private Function FF(A As Long, B As Long, C As Long, D As Long, X As Long, S As Long, ac As Long) As Long Private Function FF(A , B , C , D, X , S , ac ) 'As Long A = LongOverflowAdd4(A, (B And C) Or (Not (B) And D), X, ac) A = LongLeftRotate(A, S) A = LongOverflowAdd(A, B) End Function 'Private Function GG(A As Long, B As Long, C As Long, D As Long, X As Long, S As Long, ac As Long) As Long Private Function GG(A, B, C , D, X , S, ac)' As Long A = LongOverflowAdd4(A, (B And D) Or (C And Not (D)), X, ac) A = LongLeftRotate(A, S) A = LongOverflowAdd(A, B) End Function 'Private Function HH(A As Long, B As Long, C As Long, D As Long, X As Long, S As Long, ac As Long) As Long Private Function HH(A , B , C , D , X , S , ac )' As Long A = LongOverflowAdd4(A, B Xor C Xor D, X, ac) A = LongLeftRotate(A, S) A = LongOverflowAdd(A, B) End Function 'Private Function II(A As Long, B As Long, C As Long, D As Long, X As Long, S As Long, ac As Long) As Long Private Function II(A, B, C, D, X, S, ac)' As Long A = LongOverflowAdd4(A, C Xor (B Or Not (D)), X, ac) A = LongLeftRotate(A, S) A = LongOverflowAdd(A, B) End Function 'Function LongLeftRotate(value As Long, Bits As Long) As Long Function LongLeftRotate(value , Bits )' As Long Dim lngSign 'As Long dim lngI 'As Long Bits = Bits Mod 32 If Bits = 0 Then LongLeftRotate = value: Exit Function For lngI = 1 To Bits lngSign = value And &HC0000000 value = (value And &H3FFFFFFF) * 2 value = value Or ((lngSign < 0) And 1) Or (CBool(lngSign And &H40000000) And &H80000000) Next LongLeftRotate = value End Function 'Private Function LongOverflowAdd(Val1 As Long, Val2 As Long) As Long Private Function LongOverflowAdd(Val1 , Val2 ) 'As Long Dim lngHighWord 'As Long dim lngLowWord 'As Long dim lngOverflow 'As Long lngLowWord = (Val1 And &HFFFF&) + (Val2 And &HFFFF&) lngOverflow = lngLowWord \ 65536 lngHighWord = (((Val1 And &HFFFF0000) \ 65536) + ((Val2 And &HFFFF0000) \ 65536) + lngOverflow) And &HFFFF& 'LongOverflowAdd = UnsignedToLong((lngHighWord * 65536#) + (lngLowWord And &HFFFF&)) LongOverflowAdd = UnsignedToLong((lngHighWord * 65536) + (lngLowWord And &HFFFF&)) End Function 'Private Function LongOverflowAdd4(Val1 As Long, Val2 As Long, val3 As Long, val4 As Long) As Long Private Function LongOverflowAdd4(Val1 , Val2 , val3 , val4 )' As Long Dim lngHighWord 'As Long, dim lngLowWord 'As Long, dim lngOverflow 'As Long lngLowWord = (Val1 And &HFFFF&) + (Val2 And &HFFFF&) + (val3 And &HFFFF&) + (val4 And &HFFFF&) lngOverflow = lngLowWord \ 65536 lngHighWord = (((Val1 And &HFFFF0000) \ 65536) + ((Val2 And &HFFFF0000) \ 65536) + ((val3 And &HFFFF0000) \ 65536) + ((val4 And &HFFFF0000) \ 65536) + lngOverflow) And &HFFFF& 'LongOverflowAdd4 = UnsignedToLong((lngHighWord * 65536#) + (lngLowWord And &HFFFF&)) LongOverflowAdd4 = UnsignedToLong((lngHighWord * 65536) + (lngLowWord And &HFFFF&)) End Function 'Private Function UnsignedToLong(value As Double) As Long Private Function UnsignedToLong(value ) 'As Long If value < 0 Or value >= OFFSET_4 Then Error 6 If value <= MAXINT_4 Then UnsignedToLong = value Else UnsignedToLong = value - OFFSET_4 End Function 'Private Function LongToUnsigned(value As Long) As Double Private Function LongToUnsigned(value) 'As Double If value < 0 Then LongToUnsigned = value + OFFSET_4 Else LongToUnsigned = value End Function