Option Compare Database
Option Explicit

' ============================================================
' Windows Clipboard API
'
'     MSForms.DataObject.
'    Access CreateObject("MSForms.DataObject")
'        .
' ============================================================

#If VBA7 Then

Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
Private Declare PtrSafe Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As LongPtr) As LongPtr

Private Declare PtrSafe Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongPtr) As Long
Private Declare PtrSafe Function lstrcpyW Lib "kernel32" (ByVal lpString1 As LongPtr, ByVal lpString2 As LongPtr) As LongPtr

#Else

Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long

Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function lstrcpyW Lib "kernel32" (ByVal lpString1 As Long, ByVal lpString2 As Long) As Long

#End If

Private Const GMEM_MOVEABLE As Long = &H2
Private Const CF_UNICODETEXT As Long = 13


' ============================================================
' : mLicense
'
' :
'       Alpha-  "".
'
'  :
'   -    ;
'   -  MachineCode ;
'   -  FirstRunDate / LastRunDate;
'   -   ;
'   -   ;
'   -    ;
'   -    .
'
' :
'          .
'     Tag = RequiresLicense   ,
'    ,    MachineCode  .
'
' :
'   tAppLicense
'   tAppState
'
' :
'       ""  f:
'       txtLicenseStatus
'       txtLicenseExpireDate
'       txtMachineCode
'
'       cmdCopyMachineCode
'       cmdEnterLicenseKey
'       cmdCheckLicense
' ============================================================

Private Const PRODUCT_NAME As String = "Pivovar"
Private Const LICENSE_TYPE_ALPHA As String = "Alpha"
Private Const DEFAULT_ALPHA_DAYS As Long = 60

Private Const TABLE_LICENSE As String = "tAppLicense"
Private Const TABLE_STATE As String = "tAppState"

Private Const STATE_FIRST_RUN_DATE As String = "FirstRunDate"
Private Const STATE_LAST_RUN_DATE As String = "LastRunDate"
Private Const STATE_LAST_MACHINE_CODE As String = "LastMachineCode"
Private Const STATE_LAST_LICENSE_STATUS As String = "LastLicenseStatus"

Private Const LICENSE_STATUS_ACTIVE As String = " "
Private Const LICENSE_STATUS_NOT_FOUND As String = "  "
Private Const LICENSE_STATUS_EXPIRED As String = "  "
Private Const LICENSE_STATUS_WRONG_MACHINE As String = "    "
Private Const LICENSE_STATUS_DATE_ROLLBACK As String = "  "
Private Const LICENSE_STATUS_ERROR As String = "  "
Private Const LICENSE_STATUS_INVALID As String = "  "


' ============================================================
'    
' ============================================================

Public Sub InitializeLicenseSystem()

    '   ,   ,
    '     .
    '
    ' LastRunDate       ,
    '          
    '   .

    On Error GoTo ErrorHandler

    Call EnsureLicenseTables
    Call EnsureFirstRunState

    Exit Sub

ErrorHandler:

    MsgBox "    ." & vbCrLf & _
           ": " & Err.Description, _
           vbExclamation, _
           ""

End Sub

Public Function GetLicenseStatusText() As String

    '    .
    '
    ' :
    '   -   ;
    '   -   ;
    '   -    ;
    '   -  ;
    '   -   .
    '
    '      .
    '    ApplyLicenseToForm / ApplyLicenseToOpenForms.

    On Error GoTo ErrorHandler

    Dim currentMachineCode As String
    Dim keyMachineCode As String
    Dim keyLicenseType As String
    Dim keyExpireDate As Date
    Dim licenseKey As String
    Dim errorText As String
    Dim lastRunDate As Variant

    Call EnsureLicenseTables
    Call EnsureFirstRunState

    currentMachineCode = GetMachineCode()

    lastRunDate = GetAppStateValue(STATE_LAST_RUN_DATE)

    If IsDate(lastRunDate) Then

        If Date < CDate(lastRunDate) Then
            GetLicenseStatusText = LICENSE_STATUS_DATE_ROLLBACK
            Call SetAppStateValue(STATE_LAST_LICENSE_STATUS, GetLicenseStatusText, "   ")
            Exit Function
        End If

    End If

    If HasActiveLicenseRecord() = False Then
        GetLicenseStatusText = LICENSE_STATUS_NOT_FOUND
        Call SetAppStateValue(STATE_LAST_LICENSE_STATUS, GetLicenseStatusText, "   ")
        Call CommitCurrentRunDate
        Exit Function
    End If

    licenseKey = Nz(DLookup("[LicenseKey]", TABLE_LICENSE, "[IsActive] = True"), "")

    If ParseAndValidateLicenseKey(licenseKey, keyLicenseType, keyMachineCode, keyExpireDate, errorText) = False Then
        GetLicenseStatusText = LICENSE_STATUS_INVALID
        Call SetAppStateValue(STATE_LAST_LICENSE_STATUS, GetLicenseStatusText & ": " & errorText, "   ")
        Call CommitCurrentRunDate
        Exit Function
    End If

    If StrComp(Trim$(keyMachineCode), Trim$(currentMachineCode), vbTextCompare) <> 0 Then
        GetLicenseStatusText = LICENSE_STATUS_WRONG_MACHINE
        Call SetAppStateValue(STATE_LAST_LICENSE_STATUS, GetLicenseStatusText, "   ")
        Call CommitCurrentRunDate
        Exit Function
    End If

    If Date > keyExpireDate Then
        GetLicenseStatusText = LICENSE_STATUS_EXPIRED
        Call SetAppStateValue(STATE_LAST_LICENSE_STATUS, GetLicenseStatusText, "   ")
        Call CommitCurrentRunDate
        Exit Function
    End If

    GetLicenseStatusText = LICENSE_STATUS_ACTIVE

    Call SetAppStateValue(STATE_LAST_LICENSE_STATUS, GetLicenseStatusText, "   ")
    Call CommitCurrentRunDate

    Exit Function

ErrorHandler:

    GetLicenseStatusText = LICENSE_STATUS_ERROR & ": " & Err.Description

End Function

Public Function IsLicenseValid() As Boolean

    '  True,   .
    '
    '       
    '    .

    IsLicenseValid = (StrComp(GetLicenseStatusText(), LICENSE_STATUS_ACTIVE, vbTextCompare) = 0)

End Function


Public Function GetLicenseExpireDateText() As String

    '     .

    On Error GoTo ErrorHandler

    Dim expireDate As Variant

    Call EnsureLicenseTables

    expireDate = DLookup("[ExpireDate]", TABLE_LICENSE, "[IsActive] = True")

    If IsDate(expireDate) Then
        GetLicenseExpireDateText = Format(CDate(expireDate), "dd.mm.yyyy")
    Else
        GetLicenseExpireDateText = " "
    End If

    Exit Function

ErrorHandler:

    GetLicenseExpireDateText = ": " & Err.Description

End Function


Public Function GetMachineCode() As String

    '    .
    '
    '    / :
    '   -  ;
    '   - Windows MachineGuid;
    '   - BIOS SerialNumber;
    '   - BaseBoard SerialNumber;
    '   -  .

    On Error GoTo ErrorHandler

    Dim rawFingerprint As String
    Dim hashText As String

    rawFingerprint = GetMachineFingerprintRaw()
    hashText = HashTextSimple(rawFingerprint)

    GetMachineCode = FormatMachineCode(hashText)

    Exit Function

ErrorHandler:

    GetMachineCode = "PV-ERROR"

End Function


Public Sub RefreshLicenseInfoOnForm(ByVal targetForm As Form)

    '     .
    '
    '  :
    '   txtLicenseStatus
    '   txtLicenseExpireDate
    '   txtMachineCode

    On Error Resume Next

    Call InitializeLicenseSystem

    If ControlExistsOnForm(targetForm, "txtLicenseStatus") Then
        targetForm.Controls("txtLicenseStatus").value = GetLicenseStatusText()
    End If

    If ControlExistsOnForm(targetForm, "txtLicenseExpireDate") Then
        targetForm.Controls("txtLicenseExpireDate").value = GetLicenseExpireDateText()
    End If

    If ControlExistsOnForm(targetForm, "txtMachineCode") Then
        targetForm.Controls("txtMachineCode").value = GetMachineCode()
    End If

End Sub


Public Sub CopyMachineCodeToClipboard()

    '  MachineCode   .
    '
    '  Windows Clipboard API.
    '  ,  MSForms.DataObject,    
    '    /  Forms.

    On Error GoTo ErrorHandler

    Dim machineCode As String

    machineCode = GetMachineCode()

    If CopyTextToClipboardSafe(machineCode) = True Then

        MsgBox "     :" & vbCrLf & _
               machineCode, _
               vbInformation, _
               " "

    Else

        MsgBox "     ." & vbCrLf & vbCrLf & _
               "  :" & vbCrLf & _
               machineCode, _
               vbInformation, _
               " "

    End If

    Exit Sub

ErrorHandler:

    MsgBox "    ." & vbCrLf & vbCrLf & _
           "  :" & vbCrLf & _
           GetMachineCode(), _
           vbInformation, _
           " "

End Sub

Public Sub CreateAlphaTrialLicense()

    '   Alpha-  60    .
    '
    '      .
    '        
    '     .

    On Error GoTo ErrorHandler

    Dim db As DAO.Database
    Dim machineCode As String
    Dim expireDate As Date
    Dim licenseKey As String

    Call EnsureLicenseTables

    machineCode = GetMachineCode()
    expireDate = DateAdd("d", DEFAULT_ALPHA_DAYS, Date)
    licenseKey = GenerateLicenseKeyForMachine(machineCode, expireDate, LICENSE_TYPE_ALPHA)

    Set db = CurrentDb

    db.Execute _
        "UPDATE [" & TABLE_LICENSE & "] SET [IsActive] = False;", _
        dbFailOnError

    db.Execute _
        "INSERT INTO [" & TABLE_LICENSE & "] " & _
        "([ProductName], [LicenseType], [MachineCode], [LicenseKey], [ExpireDate], [CreatedDate], [UpdatedDate], [IsActive], [Comment]) " & _
        "VALUES (" & _
        SqlText(PRODUCT_NAME) & ", " & _
        SqlText(LICENSE_TYPE_ALPHA) & ", " & _
        SqlText(machineCode) & ", " & _
        SqlText(licenseKey) & ", " & _
        SqlDate(expireDate) & ", " & _
        SqlDateTime(Now()) & ", " & _
        SqlDateTime(Now()) & ", " & _
        "True, " & _
        SqlText("  Alpha-  60 ") & _
        ");", _
        dbFailOnError

    MsgBox "  Alpha-." & vbCrLf & _
           " : " & machineCode & vbCrLf & _
           " : " & Format(expireDate, "dd.mm.yyyy") & vbCrLf & vbCrLf & _
           ":" & vbCrLf & licenseKey, _
           vbInformation, _
           ""

    Exit Sub

ErrorHandler:

    MsgBox "    Alpha-." & vbCrLf & _
           ": " & Err.Description, _
           vbExclamation, _
           ""

End Sub


Public Sub ResetActiveLicenseForDebug(Optional ByVal showMessage As Boolean = True)

    '   .
    '
    '     .
    '    ,   ,
    '    .

    On Error GoTo ErrorHandler

    Call EnsureLicenseTables

    CurrentDb.Execute _
        "UPDATE [" & TABLE_LICENSE & "] " & _
        "SET [IsActive] = False, [UpdatedDate] = Now(), " & _
        "[Comment] = Nz([Comment], '') & Chr(13) & Chr(10) & " & _
        SqlText("    : ") & " & Format(Now(), 'dd.mm.yyyy hh:nn') " & _
        "WHERE [IsActive] = True;", _
        dbFailOnError

    Call SetAppStateValue(STATE_LAST_LICENSE_STATUS, LICENSE_STATUS_NOT_FOUND, "  ")

    If showMessage = True Then

        MsgBox "  ." & vbCrLf & _
               "      .", _
               vbInformation, _
               " "

    End If

    Exit Sub

ErrorHandler:

    MsgBox "   ." & vbCrLf & _
           ": " & Err.Description, _
           vbExclamation, _
           " "

End Sub


Public Sub EnterLicenseKeyPlaceholder()

    '      .
    '
    '    ,    
    '  cmdEnterLicenseKey_Click  f.

    On Error GoTo ErrorHandler

    Dim inputKey As String

    inputKey = InputBox( _
        "  ." & vbCrLf & vbCrLf & _
        "  :" & vbCrLf & _
        GetMachineCode(), _
        "  " _
    )

    If Trim$(inputKey) = "" Then
        Exit Sub
    End If

    If SaveLicenseKey(inputKey) = True Then

        Call ApplyLicenseToOpenForms

        MsgBox "  ." & vbCrLf & vbCrLf & _
               ": " & GetLicenseStatusText() & vbCrLf & _
               " : " & GetLicenseExpireDateText(), _
               vbInformation, _
               ""

    End If

    Exit Sub

ErrorHandler:

    MsgBox "    ." & vbCrLf & _
           ": " & Err.Description, _
           vbExclamation, _
           ""

End Sub


Public Function SaveLicenseKey(ByVal licenseKey As String) As Boolean

    '        .

    On Error GoTo ErrorHandler

    Dim keyMachineCode As String
    Dim keyLicenseType As String
    Dim keyExpireDate As Date
    Dim errorText As String
    Dim db As DAO.Database

    SaveLicenseKey = False

    Call EnsureLicenseTables

    If ValidateLicenseKeyForCurrentMachine( _
        licenseKey:=licenseKey, _
        licenseType:=keyLicenseType, _
        machineCode:=keyMachineCode, _
        expireDate:=keyExpireDate, _
        errorText:=errorText _
    ) = False Then

        MsgBox "   ." & vbCrLf & vbCrLf & _
               errorText, _
               vbExclamation, _
               ""

        Exit Function

    End If

    Set db = CurrentDb

    db.Execute _
        "UPDATE [" & TABLE_LICENSE & "] SET [IsActive] = False, [UpdatedDate] = Now();", _
        dbFailOnError

    db.Execute _
        "INSERT INTO [" & TABLE_LICENSE & "] " & _
        "([ProductName], [LicenseType], [MachineCode], [LicenseKey], [ExpireDate], [CreatedDate], [UpdatedDate], [IsActive], [Comment]) " & _
        "VALUES (" & _
        SqlText(PRODUCT_NAME) & ", " & _
        SqlText(keyLicenseType) & ", " & _
        SqlText(keyMachineCode) & ", " & _
        SqlText(NormalizeLicenseKey(licenseKey)) & ", " & _
        SqlDate(keyExpireDate) & ", " & _
        SqlDateTime(Now()) & ", " & _
        SqlDateTime(Now()) & ", " & _
        "True, " & _
        SqlText("  ") & _
        ");", _
        dbFailOnError

    SaveLicenseKey = True

    Exit Function

ErrorHandler:

    MsgBox "    ." & vbCrLf & _
           ": " & Err.Description, _
           vbExclamation, _
           ""

    SaveLicenseKey = False

End Function


Public Function ValidateLicenseKeyForCurrentMachine( _
    ByVal licenseKey As String, _
    ByRef licenseType As String, _
    ByRef machineCode As String, _
    ByRef expireDate As Date, _
    ByRef errorText As String _
) As Boolean

    '  :
    '   - ;
    '   - ;
    '   -    ;
    '   -  .

    On Error GoTo ErrorHandler

    ValidateLicenseKeyForCurrentMachine = False

    If ParseAndValidateLicenseKey(licenseKey, licenseType, machineCode, expireDate, errorText) = False Then
        Exit Function
    End If

    If StrComp(machineCode, GetMachineCode(), vbTextCompare) <> 0 Then

        errorText = _
            "    ." & vbCrLf & _
            "  : " & machineCode & vbCrLf & _
            "  : " & GetMachineCode()

        Exit Function

    End If

    If Date > expireDate Then

        errorText = "   : " & Format(expireDate, "dd.mm.yyyy")
        Exit Function

    End If

    ValidateLicenseKeyForCurrentMachine = True

    Exit Function

ErrorHandler:

    errorText = "  : " & Err.Description
    ValidateLicenseKeyForCurrentMachine = False

End Function


Private Function ParseAndValidateLicenseKey( _
    ByVal licenseKey As String, _
    ByRef licenseType As String, _
    ByRef machineCode As String, _
    ByRef expireDate As Date, _
    ByRef errorText As String _
) As Boolean

    '     .
    '
    ' :
    '   PV1-ALPHA-YYYYMMDD-XXXX-YYYY-SIGNATURE
    '
    '  MachineCode  :
    '   PV-XXXX-YYYY

    On Error GoTo ErrorHandler

    Dim normalizedKey As String
    Dim parts As Variant
    Dim prefixText As String
    Dim dateText As String
    Dim machinePart1 As String
    Dim machinePart2 As String
    Dim signatureText As String
    Dim expectedSignature As String

    ParseAndValidateLicenseKey = False
    errorText = ""

    normalizedKey = NormalizeLicenseKey(licenseKey)
    parts = Split(normalizedKey, "-")

    If UBound(parts) <> 5 Then
        errorText = "  ."
        Exit Function
    End If

    prefixText = CStr(parts(0))
    licenseType = CStr(parts(1))
    dateText = CStr(parts(2))
    machinePart1 = CStr(parts(3))
    machinePart2 = CStr(parts(4))
    signatureText = CStr(parts(5))

    If StrComp(prefixText, "PV1", vbTextCompare) <> 0 Then
        errorText = "  ."
        Exit Function
    End If

    If Len(dateText) <> 8 Or IsNumeric(dateText) = False Then
        errorText = "    ."
        Exit Function
    End If

    expireDate = DateSerial( _
        CLng(Left$(dateText, 4)), _
        CLng(Mid$(dateText, 5, 2)), _
        CLng(Right$(dateText, 2)) _
    )

    machineCode = "PV-" & machinePart1 & "-" & machinePart2

    expectedSignature = BuildLicenseSignature(licenseType, dateText, machineCode)

    If StrComp(signatureText, expectedSignature, vbTextCompare) <> 0 Then
        errorText = "    ."
        Exit Function
    End If

    ParseAndValidateLicenseKey = True

    Exit Function

ErrorHandler:

    errorText = "  : " & Err.Description
    ParseAndValidateLicenseKey = False

End Function


Public Function GenerateLicenseKeyForMachine( _
    ByVal machineCode As String, _
    ByVal expireDate As Date, _
    Optional ByVal licenseType As String = LICENSE_TYPE_ALPHA _
) As String

    '   .
    '
    '        
    '     .

    On Error GoTo ErrorHandler

    Dim normalizedMachineCode As String
    Dim normalizedLicenseType As String
    Dim dateText As String
    Dim signatureText As String
    Dim machinePart As String

    normalizedMachineCode = NormalizeMachineCode(machineCode)
    normalizedLicenseType = NormalizeLicenseType(licenseType)
    dateText = Format$(expireDate, "yyyymmdd")

    signatureText = BuildLicenseSignature(normalizedLicenseType, dateText, normalizedMachineCode)

    machinePart = Replace(normalizedMachineCode, "PV-", "")

    GenerateLicenseKeyForMachine = _
        "PV1-" & normalizedLicenseType & "-" & dateText & "-" & machinePart & "-" & signatureText

    Exit Function

ErrorHandler:

    GenerateLicenseKeyForMachine = ""

End Function


Public Sub ShowDeveloperLicenseKeyGenerator()

    '     .
    '
    '    Immediate Window:
    '   Call ShowDeveloperLicenseKeyGenerator
    '
    '        .

    On Error GoTo ErrorHandler

    Dim machineCode As String
    Dim expireText As String
    Dim expireDate As Date
    Dim licenseKey As String

    machineCode = InputBox( _
        "   .", _
        " ", _
        GetMachineCode() _
    )

    If Trim$(machineCode) = "" Then
        Exit Sub
    End If

    expireText = InputBox( _
        "      ...", _
        " ", _
        Format$(DateAdd("d", DEFAULT_ALPHA_DAYS, Date), "dd.mm.yyyy") _
    )

    If Trim$(expireText) = "" Then
        Exit Sub
    End If

    If IsDate(expireText) = False Then
        MsgBox " .", vbExclamation, " "
        Exit Sub
    End If

    expireDate = CDate(expireText)

    licenseKey = GenerateLicenseKeyForMachine(machineCode, expireDate, LICENSE_TYPE_ALPHA)

    MsgBox " :" & vbCrLf & vbCrLf & _
           licenseKey, _
           vbInformation, _
           " "

    Exit Sub

ErrorHandler:

    MsgBox "    ." & vbCrLf & _
           ": " & Err.Description, _
           vbExclamation, _
           " "

End Sub


Private Function NormalizeLicenseKey(ByVal licenseKey As String) As String

    NormalizeLicenseKey = UCase$(Trim$(licenseKey))
    NormalizeLicenseKey = Replace(NormalizeLicenseKey, " ", "")
    NormalizeLicenseKey = Replace(NormalizeLicenseKey, vbCr, "")
    NormalizeLicenseKey = Replace(NormalizeLicenseKey, vbLf, "")

End Function


Private Function NormalizeLicenseType(ByVal licenseType As String) As String

    NormalizeLicenseType = UCase$(Trim$(licenseType))

    If NormalizeLicenseType = "" Then
        NormalizeLicenseType = UCase$(LICENSE_TYPE_ALPHA)
    End If

End Function


Private Function NormalizeMachineCode(ByVal machineCode As String) As String

    Dim normalizedText As String
    Dim parts As Variant

    normalizedText = UCase$(Trim$(machineCode))
    normalizedText = Replace(normalizedText, " ", "")

    If Left$(normalizedText, 3) <> "PV-" Then
        normalizedText = "PV-" & normalizedText
    End If

    parts = Split(normalizedText, "-")

    If UBound(parts) = 2 Then
        NormalizeMachineCode = "PV-" & parts(1) & "-" & parts(2)
    Else
        NormalizeMachineCode = normalizedText
    End If

End Function


Private Function BuildLicenseSignature( _
    ByVal licenseType As String, _
    ByVal dateText As String, _
    ByVal machineCode As String _
) As String

    '   .
    '
    '    ,   Alpha- Access
    '    ACCDE      .

    Dim payloadText As String
    Dim secretText As String
    Dim part1 As String
    Dim part2 As String

    payloadText = _
        "PV1|" & _
        NormalizeLicenseType(licenseType) & "|" & _
        dateText & "|" & _
        NormalizeMachineCode(machineCode)

    secretText = GetLicenseSecret()

    part1 = HashTextLicense(payloadText & "|" & secretText)
    part2 = HashTextLicense(secretText & "|" & payloadText)

    BuildLicenseSignature = part1 & part2

End Function


Private Function GetLicenseSecret() As String

    '   .
    '
    '  ACCDE     ,  
    '    .

    GetLicenseSecret = "PV-" & "Alpha-" & "2026-" & "Sulimov-" & "Brew"

End Function


Private Function HashTextLicense(ByVal sourceText As String) As String

    '   -   .
    '
    '   LongLong,    32/64-bit Access.

    On Error GoTo ErrorHandler

    Dim i As Long
    Dim hashValue As Double
    Dim charCode As Long

    hashValue = 5381#

    For i = 1 To Len(sourceText)

        charCode = AscW(Mid$(sourceText, i, 1))

        If charCode < 0 Then
            charCode = charCode + 65536
        End If

        hashValue = hashValue * 33# + charCode

        Do While hashValue > 2147483647#
            hashValue = hashValue - 2147483647#
        Loop

    Next i

    HashTextLicense = Right$("00000000" & Hex$(CLng(hashValue)), 8)

    Exit Function

ErrorHandler:

    HashTextLicense = "00000000"

End Function


' ============================================================
'     
' ============================================================

Public Sub ApplyLicenseToForm(ByVal targetForm As Form)

    '          .
    '
    '  ,     ,
    '    Tag:
    '   RequiresLicense
    '
    '    Access   :
    '    
    '
    ' :
    '        .
    '     f, f_  f_
    '     f  SubForm/SubReport control,
    '        .

    On Error Resume Next

    Dim licenseIsValid As Boolean

    licenseIsValid = IsLicenseValid()

    Call ApplyLicenseToFormInternal(targetForm, licenseIsValid)

End Sub


Private Sub ApplyLicenseToFormInternal( _
    ByVal targetForm As Form, _
    ByVal licenseIsValid As Boolean _
)

    '   .
    '
    ' :
    '   -   ;
    '   -     ;
    '   -    ,    .

    On Error Resume Next

    Dim ctl As Control
    Dim tagText As String

    For Each ctl In targetForm.Controls

        tagText = Trim$(Nz(ctl.Tag, ""))

        If StrComp(tagText, "RequiresLicense", vbTextCompare) = 0 Then

            Select Case ctl.ControlType

                Case acCommandButton, acComboBox, acTextBox, acCheckBox, acListBox, acOptionGroup, acToggleButton
                    ctl.Enabled = licenseIsValid

            End Select

        End If

        '  .
        '
        '  SubForm/SubReport control  .Form  
        '  SourceObject .    
        '   On Error Resume Next.
        If ctl.ControlType = acSubform Then
            Err.Clear
            Call ApplyLicenseToFormInternal(ctl.Form, licenseIsValid)
            Err.Clear
        End If

    Next ctl

End Sub

Public Sub ApplyLicenseToOpenForms()

    '       .
    '
    ' ApplyLicenseToForm    ,
    '    subBrew/subCctPanel/subForfasPanel   .

    On Error Resume Next

    Dim formItem As Access.Form

    For Each formItem In Forms
        Call ApplyLicenseToForm(formItem)
    Next formItem

End Sub

Public Function RequireActiveLicense( _
    Optional ByVal operationName As String = "" _
) As Boolean

    '      .
    '
    '        ,
    '     Tag .

    On Error GoTo ErrorHandler

    Dim statusText As String

    statusText = GetLicenseStatusText()

    If StrComp(statusText, LICENSE_STATUS_ACTIVE, vbTextCompare) = 0 Then
        RequireActiveLicense = True
        Exit Function
    End If

    MsgBox operationName & " ." & vbCrLf & vbCrLf & _
           " : " & statusText & vbCrLf & vbCrLf & _
           "     .", _
           vbExclamation, _
           " Alpha-"

    RequireActiveLicense = False

    Exit Function

ErrorHandler:

    MsgBox operationName & " ." & vbCrLf & vbCrLf & _
           "   ." & vbCrLf & _
           ": " & Err.Description, _
           vbExclamation, _
           " Alpha-"

    RequireActiveLicense = False

End Function


Public Sub ShowLicenseBlockedMessage()

    '     .

    MsgBox "  ." & vbCrLf & vbCrLf & _
           " : " & GetLicenseStatusText() & vbCrLf & vbCrLf & _
           "      ." & vbCrLf & _
           "     .", _
           vbExclamation, _
           " Alpha-"

End Sub


' ============================================================
'    
' ============================================================

Public Sub EnsureLicenseTables()

    '   tAppLicense  tAppState,   .

    On Error GoTo ErrorHandler

    If TableExists(TABLE_LICENSE) = False Then
        Call CreateAppLicenseTable
    End If

    If TableExists(TABLE_STATE) = False Then
        Call CreateAppStateTable
    End If

    Exit Sub

ErrorHandler:

    Err.Raise Err.Number, Err.Source, Err.Description

End Sub


Private Sub CreateAppLicenseTable()

    On Error GoTo ErrorHandler

    CurrentDb.Execute _
        "CREATE TABLE [" & TABLE_LICENSE & "] (" & _
        "[] AUTOINCREMENT CONSTRAINT [pk_tAppLicense] PRIMARY KEY, " & _
        "[ProductName] TEXT(100), " & _
        "[LicenseType] TEXT(100), " & _
        "[MachineCode] LONGTEXT, " & _
        "[LicenseKey] LONGTEXT, " & _
        "[ExpireDate] DATETIME, " & _
        "[CreatedDate] DATETIME, " & _
        "[UpdatedDate] DATETIME, " & _
        "[IsActive] YESNO, " & _
        "[Comment] LONGTEXT" & _
        ");", _
        dbFailOnError

    Exit Sub

ErrorHandler:

    Err.Raise Err.Number, Err.Source, Err.Description

End Sub


Private Sub CreateAppStateTable()

    On Error GoTo ErrorHandler

    CurrentDb.Execute _
        "CREATE TABLE [" & TABLE_STATE & "] (" & _
        "[] AUTOINCREMENT CONSTRAINT [pk_tAppState] PRIMARY KEY, " & _
        "[StateName] TEXT(100), " & _
        "[StateValue] LONGTEXT, " & _
        "[UpdatedDate] DATETIME, " & _
        "[Comment] LONGTEXT" & _
        ");", _
        dbFailOnError

    CurrentDb.Execute _
        "CREATE UNIQUE INDEX [ux_tAppState_StateName] " & _
        "ON [" & TABLE_STATE & "] ([StateName]);", _
        dbFailOnError

    Exit Sub

ErrorHandler:

    Err.Raise Err.Number, Err.Source, Err.Description

End Sub


Private Function TableExists(ByVal tableName As String) As Boolean

    On Error GoTo ErrorHandler

    Dim tdf As DAO.TableDef

    For Each tdf In CurrentDb.TableDefs

        If StrComp(tdf.Name, tableName, vbTextCompare) = 0 Then
            TableExists = True
            Exit Function
        End If

    Next tdf

    TableExists = False

    Exit Function

ErrorHandler:

    TableExists = False

End Function



Private Sub EnsureFirstRunState()

    '  FirstRunDate  LastMachineCode,
    '    LastRunDate   .

    On Error GoTo ErrorHandler

    Dim firstRunDate As Variant
    Dim lastRunDate As Variant
    Dim machineCode As String

    firstRunDate = GetAppStateValue(STATE_FIRST_RUN_DATE)
    lastRunDate = GetAppStateValue(STATE_LAST_RUN_DATE)
    machineCode = GetMachineCode()

    If IsNull(firstRunDate) Or Len(Trim$(Nz(firstRunDate, ""))) = 0 Then
        Call SetAppStateValue(STATE_FIRST_RUN_DATE, Format(Date, "yyyy-mm-dd"), "  ")
    End If

    If IsNull(lastRunDate) Or Len(Trim$(Nz(lastRunDate, ""))) = 0 Then
        Call SetAppStateValue(STATE_LAST_RUN_DATE, Format(Date, "yyyy-mm-dd"), "  ")
    End If

    Call SetAppStateValue(STATE_LAST_MACHINE_CODE, machineCode, "  ")

    Exit Sub

ErrorHandler:

    Err.Raise Err.Number, Err.Source, Err.Description

End Sub


Private Sub CommitCurrentRunDate()

    '        .

    On Error Resume Next

    Call SetAppStateValue(STATE_LAST_RUN_DATE, Format(Date, "yyyy-mm-dd"), "  ")
    Call SetAppStateValue(STATE_LAST_MACHINE_CODE, GetMachineCode(), "  ")

End Sub


Private Sub UpdateRunState()

    '  FirstRunDate / LastRunDate / LastMachineCode.

    On Error GoTo ErrorHandler

    Dim firstRunDate As Variant
    Dim machineCode As String

    firstRunDate = GetAppStateValue(STATE_FIRST_RUN_DATE)
    machineCode = GetMachineCode()

    If IsNull(firstRunDate) Or Len(Trim$(Nz(firstRunDate, ""))) = 0 Then
        Call SetAppStateValue(STATE_FIRST_RUN_DATE, Format(Date, "yyyy-mm-dd"), "  ")
    End If

    Call SetAppStateValue(STATE_LAST_RUN_DATE, Format(Date, "yyyy-mm-dd"), "  ")
    Call SetAppStateValue(STATE_LAST_MACHINE_CODE, machineCode, "  ")

    Exit Sub

ErrorHandler:

    Err.Raise Err.Number, Err.Source, Err.Description

End Sub


Private Function GetAppStateValue(ByVal stateName As String) As Variant

    On Error GoTo ErrorHandler

    If TableExists(TABLE_STATE) = False Then
        GetAppStateValue = Null
        Exit Function
    End If

    GetAppStateValue = DLookup("[StateValue]", TABLE_STATE, "[StateName] = " & SqlText(stateName))

    Exit Function

ErrorHandler:

    GetAppStateValue = Null

End Function


Private Sub SetAppStateValue( _
    ByVal stateName As String, _
    ByVal stateValue As String, _
    Optional ByVal commentText As String = "" _
)

    On Error GoTo ErrorHandler

    Dim db As DAO.Database
    Dim existingCount As Long

    Set db = CurrentDb

    existingCount = DCount("*", TABLE_STATE, "[StateName] = " & SqlText(stateName))

    If existingCount = 0 Then

        db.Execute _
            "INSERT INTO [" & TABLE_STATE & "] " & _
            "([StateName], [StateValue], [UpdatedDate], [Comment]) " & _
            "VALUES (" & _
            SqlText(stateName) & ", " & _
            SqlText(stateValue) & ", " & _
            SqlDateTime(Now()) & ", " & _
            SqlText(commentText) & _
            ");", _
            dbFailOnError

    Else

        db.Execute _
            "UPDATE [" & TABLE_STATE & "] SET " & _
            "[StateValue] = " & SqlText(stateValue) & ", " & _
            "[UpdatedDate] = " & SqlDateTime(Now()) & ", " & _
            "[Comment] = " & SqlText(commentText) & " " & _
            "WHERE [StateName] = " & SqlText(stateName) & ";", _
            dbFailOnError

    End If

    Exit Sub

ErrorHandler:

    Err.Raise Err.Number, Err.Source, Err.Description

End Sub


Private Function HasActiveLicenseRecord() As Boolean

    On Error GoTo ErrorHandler

    HasActiveLicenseRecord = (DCount("*", TABLE_LICENSE, "[IsActive] = True") > 0)

    Exit Function

ErrorHandler:

    HasActiveLicenseRecord = False

End Function


' ============================================================
' MachineCode
' ============================================================

Private Function GetMachineFingerprintRaw() As String

    '     .

    On Error Resume Next

    Dim resultText As String

    resultText = ""

    resultText = resultText & "COMPUTER=" & Environ$("COMPUTERNAME") & "|"
    resultText = resultText & "USERDOMAIN=" & Environ$("USERDOMAIN") & "|"
    resultText = resultText & "MACHINEGUID=" & GetWindowsMachineGuid() & "|"
    resultText = resultText & "BIOS=" & GetWmiValue("Win32_BIOS", "SerialNumber") & "|"
    resultText = resultText & "BOARD=" & GetWmiValue("Win32_BaseBoard", "SerialNumber") & "|"
    resultText = resultText & "DISK=" & GetWmiValue("Win32_LogicalDisk", "VolumeSerialNumber", "DeviceID='C:'") & "|"

    GetMachineFingerprintRaw = UCase$(Trim$(resultText))

End Function


Private Function GetWindowsMachineGuid() As String

    On Error GoTo ErrorHandler

    Dim shellObject As Object

    Set shellObject = CreateObject("WScript.Shell")

    GetWindowsMachineGuid = CStr(shellObject.RegRead("HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Cryptography\MachineGuid"))

    Exit Function

ErrorHandler:

    GetWindowsMachineGuid = ""

End Function


Private Function GetWmiValue( _
    ByVal wmiClassName As String, _
    ByVal propertyName As String, _
    Optional ByVal whereCondition As String = "" _
) As String

    On Error GoTo ErrorHandler

    Dim wmiService As Object
    Dim items As Object
    Dim item As Object
    Dim queryText As String

    Set wmiService = GetObject("winmgmts:\\.\root\cimv2")

    queryText = "SELECT " & propertyName & " FROM " & wmiClassName

    If Len(Trim$(whereCondition)) > 0 Then
        queryText = queryText & " WHERE " & whereCondition
    End If

    Set items = wmiService.ExecQuery(queryText)

    For Each item In items
        GetWmiValue = Nz(CallByName(item, propertyName, VbGet), "")
        Exit Function
    Next item

    GetWmiValue = ""

    Exit Function

ErrorHandler:

    GetWmiValue = ""

End Function


Private Function HashTextSimple(ByVal sourceText As String) As String

    '   -   MachineCode.
    '
    '    .
    '  Alpha-    .
    '        .

    On Error GoTo ErrorHandler

    Dim i As Long
    Dim hashValue As Currency
    Dim charCode As Long

    hashValue = 5381

    For i = 1 To Len(sourceText)

        charCode = AscW(Mid$(sourceText, i, 1)) And &HFFFF&
        hashValue = ((hashValue * 33) + charCode)

        Do While hashValue > 2147483647
            hashValue = hashValue - 2147483647
        Loop

    Next i

    HashTextSimple = Right$("00000000" & Hex$(CLng(hashValue)), 8)

    Exit Function

ErrorHandler:

    HashTextSimple = "00000000"

End Function


Private Function FormatMachineCode(ByVal hashText As String) As String

    '    .

    hashText = Replace(hashText, "-", "")
    hashText = Replace(hashText, " ", "")
    hashText = UCase$(hashText)

    If Len(hashText) < 8 Then
        hashText = Right$("00000000" & hashText, 8)
    End If

    FormatMachineCode = "PV-" & Mid$(hashText, 1, 4) & "-" & Mid$(hashText, 5, 4)

End Function



Private Function CopyTextToClipboardSafe(ByVal sourceText As String) As Boolean

    '   Unicode-    Windows.
    '
    '     Microsoft Forms.
    '  32-bit  64-bit Access.

    On Error GoTo ErrorHandler

#If VBA7 Then

    Dim hGlobalMemory As LongPtr
    Dim lockedMemoryPointer As LongPtr
    Dim setDataResult As LongPtr
    Dim bytesCount As LongPtr

#Else

    Dim hGlobalMemory As Long
    Dim lockedMemoryPointer As Long
    Dim setDataResult As Long
    Dim bytesCount As Long

#End If

    CopyTextToClipboardSafe = False

    bytesCount = (Len(sourceText) + 1) * 2

    hGlobalMemory = GlobalAlloc(GMEM_MOVEABLE, bytesCount)

    If hGlobalMemory = 0 Then
        Exit Function
    End If

    lockedMemoryPointer = GlobalLock(hGlobalMemory)

    If lockedMemoryPointer = 0 Then
        Exit Function
    End If

    Call lstrcpyW(lockedMemoryPointer, StrPtr(sourceText))
    Call GlobalUnlock(hGlobalMemory)

    If OpenClipboard(0) = 0 Then
        Exit Function
    End If

    Call EmptyClipboard

    setDataResult = SetClipboardData(CF_UNICODETEXT, hGlobalMemory)

    Call CloseClipboard

    CopyTextToClipboardSafe = (setDataResult <> 0)

    Exit Function

ErrorHandler:

    On Error Resume Next
    Call CloseClipboard
    CopyTextToClipboardSafe = False

End Function

' ============================================================
' 
' ============================================================

Private Function ControlExistsOnForm( _
    ByVal targetForm As Form, _
    ByVal controlName As String _
) As Boolean

    On Error GoTo ErrorHandler

    Dim ctl As Control

    For Each ctl In targetForm.Controls

        If StrComp(ctl.Name, controlName, vbTextCompare) = 0 Then
            ControlExistsOnForm = True
            Exit Function
        End If

    Next ctl

    ControlExistsOnForm = False

    Exit Function

ErrorHandler:

    ControlExistsOnForm = False

End Function


Private Function SqlText(ByVal sourceValue As Variant) As String

    If IsNull(sourceValue) Then
        SqlText = "Null"
    Else
        SqlText = "'" & Replace(CStr(sourceValue), "'", "''") & "'"
    End If

End Function


Private Function SqlDate(ByVal sourceDate As Date) As String

    SqlDate = "#" & Format$(sourceDate, "yyyy\/mm\/dd") & "#"

End Function


Private Function SqlDateTime(ByVal sourceDate As Date) As String

    SqlDateTime = "#" & Format$(sourceDate, "yyyy\/mm\/dd hh\:nn\:ss") & "#"

End Function