[VB6/VBA] Serial number impl based on https://github.com/cubiclesoft/php-misc/blob/master/support/serial_number.php

mdSerialNumber.bas

'--- mdSerialNumber.bas
Option Explicit
DefObj A-Z

#Const HasPtrSafe = (VBA7 <> 0) Or (TWINBASIC <> 0)

'=========================================================================
' API
'=========================================================================

#If HasPtrSafe Then
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
'--- advapi32
Private Declare PtrSafe Function CryptAcquireContext Lib "advapi32" Alias "CryptAcquireContextW" (phProv As LongPtr, ByVal pszContainer As LongPtr, ByVal pszProvider As LongPtr, ByVal dwProvType As Long, ByVal dwFlags As Long) As Long
Private Declare PtrSafe Function CryptReleaseContext Lib "advapi32" (ByVal hProv As LongPtr, ByVal dwFlags As Long) As Long
Private Declare PtrSafe Function CryptImportKey Lib "advapi32" (ByVal hProv As LongPtr, pbData As Any, ByVal dwDataLen As Long, ByVal hPubKey As LongPtr, ByVal dwFlags As Long, phKey As LongPtr) As Long
Private Declare PtrSafe Function CryptDestroyKey Lib "advapi32" (ByVal hKey As LongPtr) As Long
Private Declare PtrSafe Function CryptGetHashParam Lib "advapi32" (ByVal hHash As LongPtr, ByVal dwParam As Long, pbData As Any, pdwDataLen As Long, ByVal dwFlags As Long) As Long
Private Declare PtrSafe Function CryptSetHashParam Lib "advapi32" (ByVal hHash As LongPtr, ByVal dwParam As Long, pbData As Any, ByVal dwFlags As Long) As Long
Private Declare PtrSafe Function CryptCreateHash Lib "advapi32" (ByVal hProv As LongPtr, ByVal AlgId As Long, ByVal hKey As LongPtr, ByVal dwFlags As Long, phHash As LongPtr) As Long
Private Declare PtrSafe Function CryptHashData Lib "advapi32" (ByVal hHash As LongPtr, pbData As Any, ByVal dwDataLen As Long, ByVal dwFlags As Long) As Long
Private Declare PtrSafe Function CryptDestroyHash Lib "advapi32" (ByVal hHash As LongPtr) As Long
Private Declare PtrSafe Function SystemTimeToVariantTime Lib "oleaut32" (lpSystemTime As Any, pvTime As Date) As Long
Private Declare PtrSafe Function VariantTimeToSystemTime Lib "oleaut32" (ByVal vTime As Date, lpSystemTime As Any) As Long
Private Declare PtrSafe Function FileTimeToSystemTime Lib "kernel32" (lpFileTime As Any, lpSystemTime As Any) As Long
Private Declare PtrSafe Function SystemTimeToFileTime Lib "kernel32" (lpSystemTime As Any, lpFileTime As Any) As Long
#Else
Private Enum LongPtr
    [_]
End Enum
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
'--- advapi32
Private Declare Function CryptAcquireContext Lib "advapi32" Alias "CryptAcquireContextW" (phProv As LongPtr, ByVal pszContainer As LongPtr, ByVal pszProvider As LongPtr, ByVal dwProvType As Long, ByVal dwFlags As Long) As Long
Private Declare Function CryptReleaseContext Lib "advapi32" (ByVal hProv As LongPtr, ByVal dwFlags As Long) As Long
Private Declare Function CryptImportKey Lib "advapi32" (ByVal hProv As LongPtr, pbData As Any, ByVal dwDataLen As Long, ByVal hPubKey As LongPtr, ByVal dwFlags As Long, phKey As LongPtr) As Long
Private Declare Function CryptDestroyKey Lib "advapi32" (ByVal hKey As LongPtr) As Long
Private Declare Function CryptGetHashParam Lib "advapi32" (ByVal hHash As LongPtr, ByVal dwParam As Long, pbData As Any, pdwDataLen As Long, ByVal dwFlags As Long) As Long
Private Declare Function CryptSetHashParam Lib "advapi32" (ByVal hHash As LongPtr, ByVal dwParam As Long, pbData As Any, ByVal dwFlags As Long) As Long
Private Declare Function CryptCreateHash Lib "advapi32" (ByVal hProv As LongPtr, ByVal AlgId As Long, ByVal hKey As LongPtr, ByVal dwFlags As Long, phHash As LongPtr) As Long
Private Declare Function CryptHashData Lib "advapi32" (ByVal hHash As LongPtr, pbData As Any, ByVal dwDataLen As Long, ByVal dwFlags As Long) As Long
Private Declare Function CryptDestroyHash Lib "advapi32" (ByVal hHash As LongPtr) As Long
Private Declare Function SystemTimeToVariantTime Lib "oleaut32" (lpSystemTime As Any, pvTime As Date) As Long
Private Declare Function VariantTimeToSystemTime Lib "oleaut32" (ByVal vTime As Date, lpSystemTime As Any) As Long
Private Declare Function FileTimeToSystemTime Lib "kernel32" (lpFileTime As Any, lpSystemTime As Any) As Long
Private Declare Function SystemTimeToFileTime Lib "kernel32" (lpSystemTime As Any, lpFileTime As Any) As Long
#End If

Private Type BLOBHEADER
    bType               As Byte
    bVersion            As Byte
    reserved            As Integer
    aiKeyAlg            As Long
    cbKeySize           As Long
    Buffer(0 To 255)    As Byte
End Type
Private Const sizeof_BLOBHEADER As Long = 12

Private Type HMAC_INFO
    HashAlgid           As Long
    pbInnerString       As LongPtr
    cbInnerString       As Long
    pbOuterString       As LongPtr
    cbOuterString       As Long
End Type

Private Type UcsBitBuffer
    Buffer()            As Byte
    Size                As Long
    Pos                 As Long
End Type

Public Type UcsSerialNumberOptions
    Expires             As Boolean
    ExpDate             As Date
    ProductClass        As Long
    MinorVer            As Long
    CustomBits          As Long
    EncryptSecret       As String
    ValidateSecret      As String
End Type

Public Function SerialNumberGenerate( _
            ByVal lProductId As Long, _
            ByVal lMajorVer As Long, _
            sUserInfo As String, _
            uOptions As UcsSerialNumberOptions) As String
    Dim uSerial         As UcsBitBuffer
    Dim baUserInfo()    As Byte
    Dim baInput()       As Byte
    Dim baHmac()        As Byte
    Dim lIdx            As Long
    Dim lJdx            As Long
    Dim uCopy           As UcsBitBuffer
    Dim aRetVal(0 To 3) As String
    
    '--- Format of each key (big-endian, 10 bytes):
    '---
    '---  1 bit:   Expires - affects Date field (0 = No, 1 = Yes)
    '--- 20 bits:  Date issued or expires ((int)(UNIX timestamp / 86400), ~2873 years)
    '--- 10 bits:  Product ID (0-1023)
    '---  4 bits:  Product classification (e.g. 0 = Standard, 1 = Pro, 2 = Enterprise)
    '---  8 bits:  Major version (0-255)
    '---  8 bits:  Minor version (0-255)
    '---  5 bits:  Custom bits per app (e.g. flags)
    '--- 24 bits:  Start of HMAC SHA-1 of the first 56 bits (7 bytes) of this serial '|' user-specific info (e.g. email).
    pvBitBufferWrite uSerial, -uOptions.Expires, 1
    pvBitBufferWrite uSerial, pvToUnixTime(uOptions.ExpDate) \ 86400, 20
    pvBitBufferWrite uSerial, lProductId, 10
    pvBitBufferWrite uSerial, uOptions.ProductClass, 4
    pvBitBufferWrite uSerial, lMajorVer, 8
    pvBitBufferWrite uSerial, uOptions.MinorVer, 8
    pvBitBufferWrite uSerial, uOptions.CustomBits, 5
    Debug.Assert uSerial.Size = 7 * 8
    baUserInfo = StrConv("|" & sUserInfo, vbFromUnicode)
    ReDim baInput(0 To 7 + UBound(baUserInfo)) As Byte
    Call CopyMemory(baInput(0), uSerial.Buffer(0), 7)
    Call CopyMemory(baInput(7), baUserInfo(0), UBound(baUserInfo) + 1)
    If Not pvGetHmacSha1(StrConv(uOptions.ValidateSecret, vbFromUnicode), baInput, baHmac) Then
        Err.Raise vbObjectError, , "pvGetHmacSha1 call failed"
    End If
    pvBitBufferWrite uSerial, baHmac(0), 8
    pvBitBufferWrite uSerial, baHmac(1), 8
    pvBitBufferWrite uSerial, baHmac(2), 8
    Debug.Assert uSerial.Size = 10 * 8
    '--- Calculate the encryption key HMAC SHA-1 of product ID (2 bytes) '|' major version (1 byte) '|' user-specific info (e.g. email).
    ReDim baInput(0 To 4 + UBound(baUserInfo)) As Byte
    baInput(0) = (lProductId \ &H100) And &HFF
    baInput(1) = lProductId And &HFF
    baInput(2) = 124 ' Asc("|")
    baInput(3) = lMajorVer And &HFF
    Call CopyMemory(baInput(4), baUserInfo(0), UBound(baUserInfo) + 1)
    If Not pvGetHmacSha1(StrConv(uOptions.EncryptSecret, vbFromUnicode), baInput, baHmac) Then
        Err.Raise vbObjectError, , "pvGetHmacSha1 call failed"
    End If
    '--- Encrypt step.  16 rounds.
    For lIdx = 1 To 16
        '--- Rotate the bits across the bytes to the right by five.  The last 5-bit chunk becomes the first 5-bit chunk.
        uCopy = uSerial
        uCopy.Pos = 75
        uSerial.Size = 0
        pvBitBufferWrite uSerial, pvBitBufferRead(uCopy, 5), 5
        uCopy.Pos = uCopy.Pos Mod 80
        Do While uSerial.Size < 80
            pvBitBufferWrite uSerial, pvBitBufferRead(uCopy, 5), 5
        Loop
        '--- Apply XOR of the first 10 bytes of the encryption key and add the other 10 bytes to the serial (10 bytes).
        For lJdx = 0 To 9
            uSerial.Buffer(lJdx) = (CLng(uSerial.Buffer(lJdx) Xor baHmac(lJdx)) + baHmac(lJdx + 10)) And &HFF
        Next
    Next
    '--- Encode step.  5-bit groups with 2x pattern, mapped to letters, hyphen every 4 characters:
    baInput = StrConv("abcdefghijkmnpqrstuvwxyz23456789", vbFromUnicode)
    uSerial.Pos = 0
    For lIdx = 0 To 3
        aRetVal(lIdx) = Chr$(baInput(pvBitBufferRead(uSerial, 5))) & Chr$(baInput(pvBitBufferRead(uSerial, 5))) & _
            Chr$(baInput(pvBitBufferRead(uSerial, 5))) & Chr$(baInput(pvBitBufferRead(uSerial, 5)))
    Next
    SerialNumberGenerate = Join(aRetVal, "-")
End Function

Public Function SerialNumberVerify( _
            sSerial As String, _
            ByVal lProductId As Long, _
            ByVal lMajorVer As Long, _
            sUserInfo As String, _
            uOptions As UcsSerialNumberOptions, _
            Optional Error As String) As Boolean
    Dim baMap(0 To 255) As Byte
    Dim lIdx            As Long
    Dim lJdx            As Long
    Dim uSerial         As UcsBitBuffer
    Dim baUserInfo()    As Byte
    Dim baInput()       As Byte
    Dim baHmac()        As Byte
    Dim uCopy           As UcsBitBuffer
    
    '--- Decode
    baInput = StrConv("abcdefghijkmnpqrstuvwxyz23456789", vbFromUnicode)
    For lIdx = 0 To UBound(baMap)
        baMap(lIdx) = &HFF
    Next
    For lIdx = 0 To UBound(baInput)
        baMap(baInput(lIdx)) = lIdx
    Next
    baInput = StrConv(sSerial, vbFromUnicode)
    For lIdx = 0 To UBound(baInput)
        If baMap(baInput(lIdx)) <> &HFF Then
            pvBitBufferWrite uSerial, baMap(baInput(lIdx)), 5
        End If
    Next
    If uSerial.Size <> 80 Then
        Error = "Invalid serial number size"
        GoTo QH
    End If
    baUserInfo = StrConv("|" & sUserInfo, vbFromUnicode)
    '--- Calculate the encryption key HMAC SHA-1 of product ID (2 bytes) '|' major version (1 byte) '|' user-specific info (e.g. email).
    ReDim baInput(0 To 4 + UBound(baUserInfo)) As Byte
    baInput(0) = (lProductId \ &H100) And &HFF
    baInput(1) = lProductId And &HFF
    baInput(2) = 124 ' Asc("|")
    baInput(3) = lMajorVer And &HFF
    Call CopyMemory(baInput(4), baUserInfo(0), UBound(baUserInfo) + 1)
    If Not pvGetHmacSha1(StrConv(uOptions.EncryptSecret, vbFromUnicode), baInput, baHmac) Then
        Err.Raise vbObjectError, , "pvGetHmacSha1 call failed"
    End If
    '--- Decrypt step.  16 rounds.
    For lIdx = 1 To 16
        For lJdx = 0 To 9
            uSerial.Buffer(lJdx) = (CLng(uSerial.Buffer(lJdx)) - baHmac(lJdx + 10)) And &HFF Xor baHmac(lJdx)
        Next
        uCopy = uSerial
        uCopy.Pos = 5
        uSerial.Size = 0
        Do While uSerial.Size < 80
            pvBitBufferWrite uSerial, pvBitBufferRead(uCopy, 5), 5
            uCopy.Pos = uCopy.Pos Mod 80
        Loop
    Next
    '--- Verify decryption.
    ReDim baInput(0 To 7 + UBound(baUserInfo)) As Byte
    Call CopyMemory(baInput(0), uSerial.Buffer(0), 7)
    Call CopyMemory(baInput(7), baUserInfo(0), UBound(baUserInfo) + 1)
    If Not pvGetHmacSha1(StrConv(uOptions.ValidateSecret, vbFromUnicode), baInput, baHmac) Then
        Err.Raise vbObjectError, , "pvGetHmacSha1 call failed"
    End If
    If uSerial.Buffer(7) <> baHmac(0) Or uSerial.Buffer(8) <> baHmac(1) Or uSerial.Buffer(9) <> baHmac(2) Then
        Error = "Invalid serial number validation"
        GoTo QH
    End If
    uOptions.Expires = pvBitBufferRead(uSerial, 1) <> 0
    uOptions.ExpDate = pvFromUnixTime(pvBitBufferRead(uSerial, 20) * 86400)
    If lProductId <> pvBitBufferRead(uSerial, 10) Then
        Error = "Invalid product validation"
        GoTo QH
    End If
    uOptions.ProductClass = pvBitBufferRead(uSerial, 4)
    If lMajorVer <> pvBitBufferRead(uSerial, 8) Then
        Error = "Invalid major version validation"
        GoTo QH
    End If
    uOptions.MinorVer = pvBitBufferRead(uSerial, 8)
    uOptions.CustomBits = pvBitBufferRead(uSerial, 5)
    '--- success
    SerialNumberVerify = True
QH:
End Function

Private Sub pvBitBufferWrite(uBuffer As UcsBitBuffer, ByVal lValue As Long, ByVal lSize As Long)
    Dim lPos            As Long
    Dim lShift          As Long
    Dim lBits           As Long
    
    With uBuffer
        Do While lSize > 0
            If .Size = 0 Then
                ReDim .Buffer(0 To 3) As Byte
            ElseIf (.Size + lSize + 7) \ 8 > UBound(.Buffer) Then
                ReDim Preserve .Buffer(0 To UBound(.Buffer) * 2 + 1) As Byte
            End If
            lPos = .Size \ 8
            lShift = 0
            lBits = 8 - .Size Mod 8
            If lBits > lSize Then
                lShift = lBits - lSize
                lBits = lSize
            End If
            .Buffer(lPos) = .Buffer(lPos) Or pvGetBits(lValue, lSize - lBits, lSize, lShift)
            .Size = .Size + lBits
            lSize = lSize - lBits
        Loop
    End With
End Sub

Private Function pvBitBufferRead(uBuffer As UcsBitBuffer, ByVal lSize As Long) As Long
    Dim lPos            As Long
    Dim lShift          As Long
    Dim lBits           As Long
    
    With uBuffer
        Do While lSize > 0
            If .Pos + lSize > .Size Then
                lSize = .Size - .Pos
            End If
            lPos = .Pos \ 8
            lShift = 0
            lBits = 8 - .Pos Mod 8
            If lBits > lSize Then
                lShift = lBits - lSize
                lBits = lSize
            End If
            pvBitBufferRead = pvBitBufferRead Or pvGetBits(.Buffer(lPos), lShift, lShift + lBits, lSize - lBits)
            .Pos = .Pos + lBits
            lSize = lSize - lBits
        Loop
    End With
End Function

Private Function pvGetBits(ByVal lValue As Long, ByVal lStartBit As Long, ByVal lEndBit As Long, ByVal lShift As Long) As Long
    Static POW2(0 To 31) As Long
    Dim lMask            As Long
    
    If POW2(0) = 0 Then
        For lMask = 0 To 30
            POW2(lMask) = 2 ^ lMask
        Next
        POW2(31) = &H80000000
    End If
    lMask = (POW2(lEndBit - lStartBit) - 1) * POW2(lStartBit)
    If lShift >= 0 Then
        pvGetBits = ((lValue And lMask) \ POW2(lStartBit)) * POW2(lShift)
    Else
        pvGetBits = ((lValue And lMask) \ POW2(lStartBit)) \ POW2(-lShift)
    End If
End Function

Private Function pvToUnixTime(ByVal dNow As Date) As Currency
    Dim aTime(0 To 7)   As Integer
    Dim cFileTime       As Currency
    
    Call VariantTimeToSystemTime(dNow, aTime(0))
    Call SystemTimeToFileTime(aTime(0), cFileTime)
    pvToUnixTime = cFileTime / 1000# - 11644473600#
    If pvToUnixTime < 0 Then
        pvToUnixTime = 0
    End If
End Function

Private Function pvFromUnixTime(ByVal cTimestamp As Currency) As Date
    Dim cFileTime       As Currency
    Dim aTime(0 To 7)   As Integer
    
    cFileTime = (cTimestamp + 11644473600#) * 1000#
    Call FileTimeToSystemTime(cFileTime, aTime(0))
    Call SystemTimeToVariantTime(aTime(0), pvFromUnixTime)
End Function

Private Function pvGetHmacSha1(baPass() As Byte, baInput() As Byte, baRetVal() As Byte) As Boolean
    '--- for CryptAcquireContext
    Const PROV_RSA_AES                  As Long = 24
    Const CRYPT_VERIFYCONTEXT           As Long = &HF0000000
    '--- for CryptCreateHash
    Const CALG_RC2                      As Long = &H6602&
    Const CALG_HMAC                     As Long = &H8009&
    Const CALG_SHA1                     As Long = &H8004&
    '--- for CryptGet/SetHashParam
    Const HP_HASHVAL                    As Long = 2
    Const HP_HMAC_INFO                  As Long = 5
    '--- for CryptImportKey
    Const PLAINTEXTKEYBLOB              As Long = 8
    Const CUR_BLOB_VERSION              As Long = 2
    Const CRYPT_IPSEC_HMAC_KEY          As Long = &H100
    Const LNG_FACILITY_WIN32            As Long = &H80070000
    Dim lHashAlgId      As Long
    Dim lHashSize       As Long
    Dim hProv           As LongPtr
    Dim uBlob           As BLOBHEADER
    Dim hKey            As LongPtr
    Dim uInfo           As HMAC_INFO
    Dim hHash           As LongPtr
    Dim hResult         As Long
    Dim sApiSource      As String
    
    lHashAlgId = CALG_SHA1
    lHashSize = 20
    If CryptAcquireContext(hProv, 0, 0, PROV_RSA_AES, CRYPT_VERIFYCONTEXT) = 0 Then
        hResult = Err.LastDllError
        sApiSource = "CryptAcquireContext"
        GoTo QH
    End If
    uBlob.bType = PLAINTEXTKEYBLOB
    uBlob.bVersion = CUR_BLOB_VERSION
    uBlob.aiKeyAlg = CALG_RC2
    Debug.Assert UBound(uBlob.Buffer) >= UBound(baPass)
    uBlob.cbKeySize = UBound(baPass) + 1
    Call CopyMemory(uBlob.Buffer(0), baPass(0), uBlob.cbKeySize)
    If CryptImportKey(hProv, uBlob, sizeof_BLOBHEADER + uBlob.cbKeySize, 0, CRYPT_IPSEC_HMAC_KEY, hKey) = 0 Then
        hResult = Err.LastDllError
        sApiSource = "CryptImportKey"
        GoTo QH
    End If
    If CryptCreateHash(hProv, CALG_HMAC, hKey, 0, hHash) = 0 Then
        hResult = Err.LastDllError
        sApiSource = "CryptCreateHash"
        GoTo QH
    End If
    uInfo.HashAlgid = lHashAlgId
    If CryptSetHashParam(hHash, HP_HMAC_INFO, uInfo, 0) = 0 Then
        hResult = Err.LastDllError
        sApiSource = "CryptSetHashParam(HP_HMAC_INFO)"
        GoTo QH
    End If
    If CryptHashData(hHash, baInput(0), UBound(baInput) + 1, 0) = 0 Then
        hResult = Err.LastDllError
        sApiSource = "CryptHashData"
        GoTo QH
    End If
    ReDim baRetVal(0 To lHashSize - 1) As Byte
    If CryptGetHashParam(hHash, HP_HASHVAL, baRetVal(0), UBound(baRetVal) + 1, 0) = 0 Then
        hResult = Err.LastDllError
        sApiSource = "CryptGetHashParam(HP_HASHVAL)"
        GoTo QH
    End If
    '--- success
    pvGetHmacSha1 = True
QH:
    If hHash <> 0 Then
        Call CryptDestroyHash(hHash)
    End If
    If hKey <> 0 Then
        Call CryptDestroyKey(hKey)
    End If
    If hProv <> 0 Then
        Call CryptReleaseContext(hProv, 0)
    End If
    If LenB(sApiSource) <> 0 Then
        Err.Raise IIf(hResult < 0, hResult, hResult Or LNG_FACILITY_WIN32), sApiSource
    End If
End Function