Hi
Firstly  great credit to the authors.
I wanted this functionality from SQL Server  so I decided to try and convert the VB to VBScript.
I had problems with data types as VB Script only has the Variant data type, but after some work I know have it working and you can just pass the parameters to the VBS script and it will output the desired licence code.
Here is an example usage from the command line:
C:\>cscript getlicencecode.vbs richard.briggs@leansoftware.net EDT
I can't see how to attach a file here so here is the VBScript (Copy and save as getlicencecode.vbs file)
' 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 <maz@mgcworks.com>
' *
' * 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 021111307 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 casesensitive 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 <maz@mgcworks.com>
' *
' * 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 021111307 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 nondiscarded 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 5bit 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 5bit 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
Richard Briggs
