Using VB to Create & Check License Keys

Hi,

Forgive my ignorance as I am new to this type of programming, I've done COBOL and SAP/ABAP for 30 years but this is new terrain.

I've imported the 3 .bas files into my VBA but how do I invoke what I need to in VBA to have it check if the license is good. I can execute KeyCode.exe but I don't understand the relationship to VBA.

If anyone has a simple example of what should be invoked and the order to invoke each function.

thx
mike

When I have converted the same project to VB.net. The generated license key is not matching

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

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

Richard Briggs

Out of interest - having a VBScript version means you can call this now from any language I think - and just capture the output. So can be used in .NET (VB,C#), SQL Server, PHP etc etc.

When I convert solution to VS2005, and I try to run it, it always says "Arithmetic operation resulted in an overflow." in MD5_crypt.vb class in function "LongOverflowAdd4" on second line...
Anyone can help me? Please

Has anyone done this as in the suggested modification to get "more professional" looking key?

Shortening it on the creation side is easy but I can't figure out how to modify iskeyvalid or ValidateKeyCode to validate it.

Here's what I"m doing to shorten it:

VB

Dim strShortenedBase32 As String
    strShortenedBase32 = Left(Base32Enc(BinKey), 25)

   'in groups of 5 instead of 4
 KeyCode = FormatKeyCode(strShortenedBase32, 5)

Also, has anyone converted this to a PHP script to generate on the server side ? Thank you.

Thanks. And thank you maz2331 !

Hello,
do you share also a dll or a C# version?

Best Regards

Nice idea.

Anyone able to get this to work with VBA and Access 2010?

You say that you can use this in access but the downloaded files can't be imported into access so how can I put it in access?

I haven't tried this on Access 2010 yet, but I have managed to get it working under Access 2003

I am integrating this code example in to a project and found that the sample apps included with the project produce different keys if the target system is set to Japanese (the language of the user who discovered this).

This means that keys generated by my English locale machine do not work if the IsKeyValid procedure within the application is run on a Japanese machine. I am a 'scratch the surface' VB developer and have not been able to isolate which module(s) and procedure(s) are causing this issue but I assume it is something to do with Unicode.

I have been able to replicate the behavior by setting my WinXP machine up as follows:

1. Control Panel / Regional and Language Options / Languages : Install files for East Asian languages

2. Control Panel / Regional and Language Options / Advanced : select 'Japanese' for non-Unicode programs

This is an example output from the untouched sample app:

English Locale: Takashi Kawaguchi -> 57J2-SM19-PBXJ-VR47-R6MG-86JS-FP
Japanese Locale: Takashi Kawaguchi -> 0102-G001-G002-R000-06MG-00JS-80

I would love to know how to fix this Smile | :)

I haven't reviewed the code sample for this project, but I have had this exact problem with my own product key encoder/validator for the Chinese Taiwan language set. Frown | :(

However, the answer was as simple as changing the text encoding type to ASCII for all my file write and read routines, and changing the default language sets to English (en-us). Smile | :)

For our software requiring a code key, we have the user input it, we validate it, and if passes we write it to registration file which program checks for when first loaded to run in demo mode or full mode. Cool | :cool:

Code excerpts for VB2008e below:

{Place at top of code before first public class}Imports System
Imports System.Globalization
Imports System.Security.Permissions
Imports System.Threading
Imports System.Resources
Imports System.IO

{Place at beginning of main code class}
' Changes the CurrentCulture of the current thread to en-US. Thread.CurrentThread.CurrentCulture = New CultureInfo("en-US", False)
Thread.CurrentThread.CurrentUICulture = New CultureInfo("en-US", False)

{Place as necessary to restrict the Product Key writing to pure ASCII}
Dim myProductKey As New StreamWriter(myFilePath, False, System.Text.Encoding.ASCII)

{Place as necessary to restrict the Product Key reading to pure ASCII}
Dim myProductKey As New StreamReader(myFilePath, System.Text.Encoding.ASCII)
........^--your own variable........................^--complete path/filename to product key file

{Since unicode is the default for VB2008e, create pure ascii string for input set}
Dim myAllowedChars As String = ""
'ASCII values for "0123456789"
For vm = 48 To 57
myAllowedChars += Chr(vm)
Next
'ASCII values for "ABCDEFGHIJKLMNP"
For vn = 65 To 78
myAllowedChars += Chr(vn)
Next
'Skip the Letter "O" to prevent confusion with Zero"0"
'ASCII values for "QRSTUVWXYZ"
For vo = 80 To 90
myAllowedChars += Chr(vo)
Next

GOOD LUCK and HAPPY CODING!
RoLoW

Thanks Richard. The idea about converting strings to ASCII prior to running them through the KeyGen module is a good one and will be useful for a new issue I've discovered when running this KeyGen code on a PC and then on a Mac in VBA. I think code pages are causing it to ge messed up Frown | :-(

Back to the original 'Windows only' issue, I'm not sure that your suggestion will help since the user names in the example above are already in pur ASCII and there are no file IO operations on the string during the conversion to a key.

This project is very powerful since it allows VBA (not VB) developers to attach licensing modules to code in order to create cross-platform compatible application for Office on the PC and Mac but these locale issues are causing a few headaches.

I't would be great to work with the original developer to try to make it more robust.

The code can be fixed quite easily to overcome this problem.

The issue is DBCS (double byte character set) systems. Where the source code is using Asc() and Chr(), these can be replaced with AscW() and ChrW(). This should generate the same license key codes whatever the Windows regional settings are for "Language settings for non-Unicode programs".

Just do a careful -- because some variables are using "Chr" string in the name -- text find & replace for these functions and the code should work fine.

I'm using a slightly modified version of the code, but I already encountered this issue and fixed it using this approach.

Hope this helps anyone who wants to use the source code in an international setting.

modified 11-Apr-13 13:42pm.

This is superb!

We've made the [careful] search & replace change from Asc() to AscW() and Chr() to ChrW() in the three modules and checked it on a Windows 7 machine with the locale set to Japan (where it broke before) and it's now working as expected.

Thank you very much EmpiricaConsultingLtd Smile | :)

I need the same project in vb.net.
I have converted this project but the license key which gets generate is not valid.

Kindly assist on this pls.

It's not clear to me from your message whether you're asking about any specific issues with Unicode.

I'm glad to see you also sensibly added your message to the main discussion thread where it may get more attention. Smile | :)

You might need to add more detail to your request for help.

Good luck. Smile | :)

Hi,

Can you provide the C# (.net) version of this application.

With regards

"Don't go the way life takes you…... Take the life the way you go……….."

When you say change Base32 string to 25 from 26 where is this done?

Phil

Software Developer
http://www.yorkshirehumberit.co.uk

I am new to vb programming( vb 2005).
i have written sample code, which i would to license. I found article on site named:Using VB to create & check license keys
By maz2331

I am not clear how to include BAS file mentioned to VB 2005 code.
Can somebody explain with example how would use the code?, as sample is not clear how i will do so.

Best Regards

MB

Hi,

I also get loads of errors while converting it to VB2008 express and VS2008

I tried to get all the errors out but my limited knowledge of code programming has reached his limit.

Could you please help? $Shucks | :-\$

pjvdstap
The Netherlands

It's easy to convert to VB2005 using the build in convertion program.

After conversion you'll get errors to almost all CShort() functions. But don't worry, you can just take all CShort functions out.
Now the program works brilliantly!

For converting it to VS2008 I can't give you any advise, but I understand this conversion should not be that difficult.

I also tried to convert the program to C# by using one of the free conversion sites you find in Google. Unfortunately that has proven to be quite difficult and took me quite a few hours. It's probably easier to create a encode/decode dll in VB.Net and import it into your C# project.

Happy coding everyone!

Dennis

Thanks a lot for this tip. Works beautifully.

Is this avaiable in VB.net allso please?
(I tried to convert this to VB.NET 2008, but a lot of error occur)

Using VB to Create & Check License Keys

Introduction

Background

Using the Code

Key Strength

Sample Screenshots

History

License

Comments and Discussions