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)
Option Explicit
Private Const OFFSET_4 = 4294967296
Private Const MAXINT_4 = 2147483647
Private State
Private ByteCounter
Private ByteBuffer()
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
State = Array(cdbl(1),cdbl(1),cdbl(1),cdbl(1),cdbl(1))
for i = 1 to 64
redim preserve ByteBuffer(i)
ByteBuffer(i) = cbyte(0)
next
Dim Email, App, args,ans,i
Email = args.Item(0)
App = args.Item(1)
ans = FormatKeyCode(GenKeyString(Email,App, 0),5)
Wscript.Echo ans
Public Function GenKeyString(ByVal UserName, ProdName , F_Code )
Dim TempStr
Dim KeyStr
Dim KeyVal
Dim CodeVal
Dim CodeLow
Dim CodeHigh
Dim KeyLowV1
Dim KeyLowV2
Dim KeyLow1
Dim KeyLow2
Dim ChrV1
Dim ChrV2
TempStr = LCase(UserName) & LCase(ProdName)
KeyStr = DigestStrToHexStr(TempStr)
KeyVal = HexStrToBinStr(KeyStr)
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)
ChrV1 = Chr(KeyLowV1)
ChrV2 = Chr(KeyLowV2)
KeyVal = Mid(KeyVal, 1, Len(KeyVal) - 2)
KeyVal = KeyVal & ChrV2 & ChrV1
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
Public Function ValidateKeyCode(ByVal KeyCode, UserName, ProjName )
Dim ActiveBytes
Dim LUNameHash
Dim LUName
Dim ValidKey
Dim KeyMD5
Dim KeySig
ValidKey = False
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
Public Function ExtractKeyFBits(ByVal KeyCode, UserName, ProjName )
Dim PermVal
Dim RealHash
Dim LUser
Dim Perms
Dim BinCodePerm
Dim BinUHashPerm
Dim HiCodePerm
Dim HIUMask
Dim LoUMask
Dim HiPerm
Dim LoPerm
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
Dim CurGrp
Dim OutStr
Dim GrpStr
Dim GrpStart
StrLen = Len(StrIn)
dim strGroups, StrLeftOver
strGroups = Int(StrLen / GrpLen)
StrLeftOver = StrLen Mod GrpLen
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
If StrLeftOver > 0 Then
OutStr = OutStr & "-" & Right(StrIn, StrLeftOver)
End If
FormatKeyCode = OutStr
End Function
Const B32Map = "0123456789ABCDEFGHJKLMNPRSTVWXYZ"
Public Function RemoveDashes(ByVal StrIn )
RemoveDashes = Replace(StrIn, "-", "")
End Function
Public Function ShiftStrLeft(ByVal StrIn , ByVal Bits )
Dim CurPos
Dim WorkStr
Dim RetStr
Dim CurByteVal
Dim BitMask
Dim InvMask
Dim ShiftBits
Dim WholeBytes
Dim LeftPart
Dim RightPart
Dim Carry
Dim PrevChar
Dim TrimMask
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
If (StrBits > Bits) Then
If (WholeBytes > 0) Then
WorkStr = Right(WorkStr, StrLen - WholeBytes)
For CurPos = 1 To WholeBytes
WorkStr = WorkStr & Chr(0)
Next
RetStr = WorkStr
End If
If (ShiftBits > 0) Then
For CurPos = 1 To Len(WorkStr)
CurByteVal = Asc(Mid(WorkStr, CurPos, 1))
LeftPart = (CurByteVal And BitMask) And &HFF
RightPart = (CurByteVal And InvMask) And &HFF
LeftPart = Int(LeftPart / (2 ^ (8 - ShiftBits)))
RightPart = (RightPart * (2 ^ ShiftBits))
If CurPos = 1 Then
PrevChar = (RightPart)
RetStr = ""
Else
PrevChar = PrevChar Or LeftPart
RetStr = RetStr & Chr(PrevChar)
PrevChar = RightPart
End If
Next
PrevChar = (PrevChar Or (LeftPart And Not (TrimMask)))
RetStr = RetStr & Chr(PrevChar)
End If
Else
For CurPos = 1 To StrLen
RetStr = RetStr & Chr(0)
Next
End If
ShiftStrLeft = RetStr
End Function
Public Function ShiftStrRight(ByVal StrIn , ByVal Bits )
Dim CurPos
Dim WorkStr
Dim RetStr
Dim CurByteVal
Dim BitMask
Dim InvMask
Dim ShiftBits
Dim WholeBytes
Dim LeftPart
Dim RightPart
Dim Carry
Dim PrevChar
Dim TrimMask
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
WorkStr = StrIn
If (StrBits > Bits) Then
If (WholeBytes > 0) Then
WorkStr = Left(WorkStr, StrLen - WholeBytes)
For CurPos = 1 To WholeBytes
WorkStr = Chr(0) & WorkStr
Next
RetStr = WorkStr
End If
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
RetStr = Chr(Carry) & RetStr
End If
Else
For CurPos = 1 To StrLen
RetStr = RetStr & Chr(0)
Next
End If
ShiftStrRight = RetStr
End Function
Public Function Base32Enc(ByVal StrIn )
Dim CurBit
Dim Mask32
Dim CurPos
Dim CurVal
Dim StrBits
Dim BitsProc
Dim WorkStr
Dim RetStr
Dim CurConv
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
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
Base32Enc = RetStr
End Function
Public Function Base32Dec(ByVal StrIn )
Dim CurPos
Dim CurVal
Dim CurChr
Dim RetStr
Dim WorkStr
Dim Carry
Dim CarryMask
Dim CurMask
Dim ThisVal
Dim ThisChar
Dim ShiftBits
Dim OutBytes
Dim InBits
BitsProc = 0
BaseMask = &H1F
Carry = 0
WorkStr = StrIn
InBits = Len(StrIn) * 5
OutBytes = Int(InBits / 8)
For CurPos = 1 To OutBytes
RetStr = RetStr & Chr(0)
Next
For CurPos = 1 To Len(StrIn)
CurChr = Mid(WorkStr, CurPos, 1)
CurVal = InStr(1, B32Map, CurChr)
CurVal = CurVal - 1
RetStr = ShiftStrLeft(RetStr, 5)
ThisChar = Mid(RetStr, Len(RetStr), 1)
RetStr = Left(RetStr, Len(RetStr) - 1)
ThisVal = Asc(ThisChar)
ThisVal = ThisVal Or CurVal
ThisChar = Chr(ThisVal)
RetStr = RetStr & ThisChar
Next
Base32Dec = RetStr
End Function
Public Function HexStrToBinStr(ByVal StrIn )
Dim StrOut
Dim Ch
Dim HexByte
Dim ByteVal
Dim ByteCh
StrOut = ""
For Ch = 1 To Len(StrIn) Step 2
HexByte = Mid(StrIn, Ch, 2)
ByteVal = cint("&H" & HexByte)
ByteCh = Chr(ByteVal)
StrOut = StrOut & ByteCh
Next
HexStrToBinStr = StrOut
End Function
Public Function BinStrToHexStr(ByVal StrIn )
Dim StrOut
Dim Ch
Dim HexByte
Dim HexChr
StrOut = ""
For Ch = 1 To Len(StrIn)
HexByte = Mid(StrIn, Ch, 1)
HexChr = Hex(Asc(HexByte))
If Len(HexChr) = 1 Then HexChr = "0" & HexChr
StrOut = StrOut & HexChr
Next
BinStrToHexStr = StrOut
End Function
Function RegisterA()
RegisterA = State(1)
End function
Function RegisterB()
RegisterB = State(2)
End function
Function RegisterC()
RegisterC = State(3)
End function
Function RegisterD()
RegisterD = State(4)
End function
Public Function DigestStrToHexStr(SourceString )
MD5Init
MD5Update Len(SourceString), StringToArray(SourceString)
MD5Final
DigestStrToHexStr = GetValues
End Function
Private Function StringToArray(InString )
Dim i
dim bytBuffer()
ReDim bytBuffer(Len(InString))
For i = 0 To Len(InString) - 1
bytBuffer(i) = Asc(Mid(InString, i + 1, 1))
Next
StringToArray = bytBuffer
End Function
Public Function GetValues()
GetValues = LongToString(State(1)) & LongToString(State(2)) & LongToString(State(3)) & LongToString(State(4))
End Function
Private Function LongToString(Num)
Dim A
dim B
dim C
dim D
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(cDbl(1732584193))
State(2) = UnsignedToLong(cDbl(4023233417))
State(3) = UnsignedToLong(cDbl(2562383102))
State(4) = UnsignedToLong(cdbl(271733878))
End Sub
Public Sub MD5Final()
Dim dblBits
dim padding(72)
dim lngBytesBuffered
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
dim i
dim J
dim K
dim lngBufferedBytes
dim lngBufferRemaining
dim lngRem
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
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
MD5Transform ByteBuffer
Next
lngBufferedBytes = 0
Else
i = 0
End If
For K = 0 To InputLen - i - 1
ByteBuffer(lngBufferedBytes + K) = InputBuffer(i + K)
Next
End Sub
Private Sub MD5Transform(Buffer() )
Dim X(16)
dim A
dim B
dim C
dim D
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
dim intByteIndex
dim dblSum
For intByteIndex = 0 To Length - 1 Step 4
dblSum = InputBuffer(intByteIndex) + InputBuffer(intByteIndex + 1) * 256 + InputBuffer(intByteIndex + 2) * 65536 + InputBuffer(intByteIndex + 3) * 16777216
OutputBuffer(intDblIndex) = UnsignedToLong(dblSum)
intDblIndex = intDblIndex + 1
Next
End Sub
Private Function FF(A , B , C , D, X , S , ac )
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, B, C , D, X , S, ac)
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 , B , C , D , X , S , ac )
A = LongOverflowAdd4(A, B Xor C Xor D, X, ac)
A = LongLeftRotate(A, S)
A = LongOverflowAdd(A, B)
End Function
Private Function II(A, B, C, D, X, S, ac)
A = LongOverflowAdd4(A, C Xor (B Or Not (D)), X, ac)
A = LongLeftRotate(A, S)
A = LongOverflowAdd(A, B)
End Function
Function LongLeftRotate(value , Bits )
Dim lngSign
dim lngI
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 , Val2 )
Dim lngHighWord
dim lngLowWord
dim lngOverflow
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&))
End Function
Private Function LongOverflowAdd4(Val1 , Val2 , val3 , val4 )
Dim lngHighWord
dim lngLowWord
dim lngOverflow
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&))
End Function
Private Function UnsignedToLong(value )
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)
If value < 0 Then LongToUnsigned = value + OFFSET_4 Else LongToUnsigned = value
End Function
Richard Briggs
|