Attribute VB_Name = "ValidationFunctions"
Option Explicit
'This module contains validation functions for app startup, login and registration
'It also contains the code to check the number of active horses

Public Function ValidateInstallation() As Integer
   Dim rst As ADODB.Recordset
   Dim rst2 As ADODB.Recordset
   Dim strSQL As String
   Dim blnMissingAdminName As Boolean
   Dim blnMissingUserName As Boolean
      
   'Check the Login Names exist
   Set rst = New ADODB.Recordset
   Set rst2 = New ADODB.Recordset
   strSQL = "SELECT * From tUser"
   rst.Open strSQL, Main.cn, adOpenDynamic, adLockOptimistic
   ValidateInstallation = 0
   If rst.EOF Then 'if no login names exist then create an admin login
      rst.AddNew
      rst.Fields("strUserName") = "admin"
      rst.Fields("strPassword") = "admin"
      rst.Fields("blnDebtors") = True
      rst.Fields("blnMonthEnd") = True
      rst.Fields("blnTrainer") = True
      rst.Fields("blnBreeder") = True
      rst.Fields("blnCurrent") = True
      rst.Fields("blnHistory") = True
      rst.Fields("blnSetup") = True
      rst.Fields("blnOrig") = True
      rst.Update
   End If
   rst.Close
   
   strSQL = "SELECT * From tCompany"
   rst.Open strSQL, Main.cn, adOpenDynamic, adLockOptimistic
   If Not rst.EOF Then
      If (IsNull(rst.Fields("refID"))) Or (Len(Trim(rst.Fields("refID"))) = 0) Then
         ValidateInstallation = 1
         rst.Update
      End If
      If (IsNull(rst.Fields("strName"))) Or (Len(Trim(rst.Fields("strName"))) = 0) Then
         ValidateInstallation = 1
         rst.Update
      End If
   Else
      ValidateInstallation = 1
   End If
   If ValidateInstallation = 0 Then
      If CompareKey(Trim(rst.Fields("strName")), rst.Fields("refID")) = False Then
         ValidateInstallation = 1
      End If
   End If
   If ValidateInstallation = 0 Then
      If isValidNumHorses(rst.Fields("refID")) = False Then
         ValidateInstallation = 1
         MsgBox "The Number of Active Horses Exceeds the number you are registered for! Please supply a new registration code.", vbExclamation + vbOKOnly
      End If
   End If
' check to see if reregister code
   If ValidateInstallation = 0 Then
      strSQL = "SELECT * From tSystem"
      rst2.Open strSQL, Main.cn, adOpenDynamic, adLockOptimistic
      If rst2.EOF Then
         With rst2 ' ensure record exists in tSystem
            .AddNew
            .Fields("dblInterestRate") = 0
            .Fields("dblVAT") = 0
            .Fields("lngNextInvoiceNo") = 1
            .Fields("strRegister") = ""
            .Update
         End With
      End If
      If Not rst.EOF Then
         If (IsNull(rst2.Fields("strRegister"))) Or (Len(Trim(rst2.Fields("strRegister"))) = 0) Then
            If CheckDateKey(rst.Fields("refID")) = False Then
               ValidateInstallation = 2
            End If
         Else
            If Len(Trim(rst2.Fields("strRegister"))) = 10 Then
               If isValidReregisterCode(rst.Fields("refID"), rst2.Fields("strRegister")) = False Then
                  ValidateInstallation = 2
               End If
            Else
               If CheckDateKey(rst.Fields("refID")) = False Then
                  ValidateInstallation = 2
               End If
            End If
         End If
      Else
         If CheckDateKey(rst.Fields("refID")) = False Then
            ValidateInstallation = 2
         End If
      End If
      rst2.Close
   End If
   rst.Close
End Function

Public Sub ValidateGL()
   Dim rst1 As ADODB.Recordset
   Dim rst2 As ADODB.Recordset
   Dim strSQL As String
   Dim blnMissingGL1Name As Boolean
   Dim blnMissingGL2Name As Boolean
   Dim blnMissingGL1 As Boolean
   Dim blnMissingGL2 As Boolean
   
   Set rst1 = New ADODB.Recordset
   strSQL = "SELECT * From tGLAccountName ORDER BY tGLAccountName.GLAccountNameIR;"
   rst1.Open strSQL, Main.cn, adOpenDynamic, adLockOptimistic
      
   Set rst2 = New ADODB.Recordset
   strSQL = "SELECT * From tGL ORDER BY tGL.GLIR;"
   rst2.Open strSQL, Main.cn, adOpenDynamic, adLockOptimistic

   
   If rst1.EOF Then
      If rst2.EOF Then
         With rst1
            .AddNew
            .Fields("GLAccountNameIR") = 1
            .Fields("strDescription") = "Int"
            .Update
            .AddNew
            .Fields("GLAccountNameIR") = 2
            .Fields("strDescription") = "Comm"
            .Update
            .AddNew
            .Fields("GLAccountNameIR") = 3
            .Fields("strDescription") = "Receipts"
            .Update
         End With
         With rst2
            .AddNew
            .Fields("GLIR") = 1
            .Fields("refGLAccountNameID") = 1
            .Fields("strDescription") = "Interest on Overdue Accounts"
            .Fields("bVatCharge") = False
            .Fields("bDiscountable") = False
            .Fields("bMonthly") = False
            .Fields("bOwnerCharge") = True
            .Update
            .AddNew
            .Fields("GLIR") = 2
            .Fields("refGLAccountNameID") = 2
            .Fields("strDescription") = "Commission on Stakes"
            .Fields("bVatCharge") = True
            .Fields("bDiscountable") = False
            .Fields("bMonthly") = False
            .Fields("bOwnerCharge") = False
            .Update
            .AddNew
            .Fields("GLIR") = 3
            .Fields("refGLAccountNameID") = 3
            .Fields("strDescription") = "Payment - Thank You"
            .Fields("bVatCharge") = False
            .Fields("bDiscountable") = False
            .Fields("bMonthly") = False
             .Fields("bOwnerCharge") = True
           .Update
         End With
      Else
         'rst2 should never have entries with out rst1 having entries
         MsgBox "Possible Error in General Ledger Detected!", vbOKOnly + vbCritical, "Warning"
      End If
      rst1.Close
      rst2.Close
   End If
End Sub

Public Function CalcFinalDigits(tmpString As String) As String
   Dim intX As Integer
   Dim intY As Integer

   intX = Val(Mid(tmpString, 1, 1)) * (Val(Mid(tmpString, 2, 1)) + Val(Mid(tmpString, 3, 1)) + Val(Mid(tmpString, 4, 1)))
   intY = Val(Mid(tmpString, 5, 1)) * (Val(Mid(tmpString, 6, 1)) + Val(Mid(tmpString, 7, 1)) + Val(Mid(tmpString, 8, 1)))
   CalcFinalDigits = tmpString & Left(Trim(Str(intX + intY)), 2)
End Function

Public Function CompareKey(strName As String, refID As String) As Boolean
   Dim i As Integer
   Dim strKey As String
   Dim tmpFullKey As String
   
   tmpFullKey = refID
   If Len(refID) = 16 Then
      refID = Left(tmpFullKey, 2) & Mid(tmpFullKey, 4, 8)
      'check length and pad if neccessary
      If Len(strName) < 3 Then
         strName = strName + Space(4 - Len(strName))
      End If
      strKey = ""
      'retrieve first random number
      strKey = strKey & Left(refID, 1)
      'strip first three characters
      For i = 1 To 3
         strKey = strKey & GetDigit(Mid(strName, i, 1))
      Next i
      'retrieve second random number
      strKey = strKey & Mid(refID, 5, 1)
      'strip last 3 characters
      For i = Len(strName) - 2 To Len(strName)
         strKey = strKey & GetDigit(Mid(strName, i, 1))
      Next i
      
      If Left(CalcFinalDigits(strKey), 2) = Left(refID, 2) And Right(CalcFinalDigits(strKey), 8) = Right(refID, 8) Then
         If Mid(tmpFullKey, 3, 1) = 5 Or Mid(tmpFullKey, 3, 1) = 6 Or Mid(tmpFullKey, 3, 1) = 7 Or Mid(tmpFullKey, 3, 1) = 8 Or Mid(tmpFullKey, 3, 1) = 9 Then
            CompareKey = True
         Else
            CompareKey = False
         End If
      Else
         CompareKey = False
      End If
   Else
      CompareKey = False
   End If
End Function

Public Function GetDigit(strCharacter As String) As String
   strCharacter = UCase(strCharacter)
   Select Case strCharacter
      Case "C"
         GetDigit = 1
      Case "K"
         GetDigit = 1
      Case "V"
         GetDigit = 1
      Case "F"
         GetDigit = 2
      Case "M"
         GetDigit = 2
      Case "W"
         GetDigit = 2
      Case "G"
         GetDigit = 3
      Case "O"
         GetDigit = 3
      Case "T"
         GetDigit = 3
      Case "D"
         GetDigit = 4
      Case "L"
         GetDigit = 4
      Case "Y"
         GetDigit = 4
      Case "B"
         GetDigit = 5
      Case "Q"
         GetDigit = 5
      Case "S"
         GetDigit = 5
      Case "I"
         GetDigit = 6
      Case "N"
         GetDigit = 6
      Case "X"
         GetDigit = 6
      Case "A"
      GetDigit = 7
      Case "J"
         GetDigit = 7
      Case "U"
         GetDigit = 7
      Case "E"
         GetDigit = 8
      Case "R"
         GetDigit = 8
      Case "Z"
         GetDigit = 8
      Case "H"
         GetDigit = 9
      Case "P"
         GetDigit = 9
      Case Else
         GetDigit = 0
   End Select
End Function

Public Function getRandom() As Integer 'generate random number between 2 and 9
   Randomize
   getRandom = Int(8 * Rnd + 2)
End Function

'procedures to determine if the user has more active horses than they are licensed for

Public Function isValidNumHorses(strRefID As String) As Boolean
   Dim rst As ADODB.Recordset
   Dim strSQL As String
   Dim lngTotalActiveHorses As Long
   Dim lngMaxActiveHorses As Long
   
   Set rst = New ADODB.Recordset
   
   lngTotalActiveHorses = 0
   strSQL = "SELECT Count(tHorse.HorseIR) AS CountOfHorseIR From tHorse WHERE (((tHorse.bStatus)=True));"
   rst.Open strSQL, Main.cn, adOpenForwardOnly
   If Not rst.EOF Then
      lngTotalActiveHorses = rst.Fields("CountOfHorseIR")
   End If
   rst.Close
   
   lngMaxActiveHorses = GetMaxHorses(Mid(strRefID, 3, 1))
   If lngMaxActiveHorses > 0 And lngMaxActiveHorses < lngTotalActiveHorses Then
      isValidNumHorses = False
   Else
      isValidNumHorses = True
   End If
End Function

Public Function GetMaxHorses(strCode As String) As Integer
   Select Case strCode
      Case "9"
         GetMaxHorses = 30     ' 1 - 30
      Case "6"
         GetMaxHorses = 60     ' 31 - 60
      Case "7"
         GetMaxHorses = 100    ' 61 - 100
      Case "8"
         GetMaxHorses = 200    ' 101 - 200
      Case "5"
         GetMaxHorses = -1     ' 201 +
   End Select
End Function

Public Function canAddHorse() As Boolean
   Dim rst As ADODB.Recordset
   Dim strSQL As String
   Dim lngTotalActiveHorses As Long
   Dim lngMaxActiveHorses As Long
   Dim strRefID As String
   
   Set rst = New ADODB.Recordset
   canAddHorse = False
   
   strRefID = ""
   strSQL = "SELECT * FROM tCompany"
   rst.Open strSQL, Main.cn, adOpenForwardOnly
   If Not rst.EOF Then
      strRefID = rst.Fields("refID")
   End If
   rst.Close
   
   lngTotalActiveHorses = 0
   strSQL = "SELECT Count(tHorse.HorseIR) AS CountOfHorseIR From tHorse WHERE (((tHorse.bStatus)=True));"
   rst.Open strSQL, Main.cn, adOpenForwardOnly
   If Not rst.EOF Then
      lngTotalActiveHorses = rst.Fields("CountOfHorseIR")
   End If
   rst.Close
   lngTotalActiveHorses = lngTotalActiveHorses + 1
   
   lngMaxActiveHorses = GetMaxHorses(Mid(strRefID, 3, 1))
   If lngMaxActiveHorses > 0 And lngMaxActiveHorses < lngTotalActiveHorses Then
      canAddHorse = False
   Else
      canAddHorse = True
   End If
End Function

Public Function isValidReregisterCode(strRefID As String, strCode As String) As Boolean
   Dim s As String
   Dim intOdd As Integer
   Dim intEven As Integer
   Dim x As Integer
  
   isValidReregisterCode = True
   s = ""
   For x = 1 To Len(strCode)
      s = s & ReregisterDigit(Mid(strCode, x, 1))
   Next x
   intOdd = 0
   For x = 1 To Len(strRefID) Step 2
      intOdd = intOdd + Mid(strRefID, x, 1)
   Next x
   intEven = 0
   For x = 2 To Len(strRefID) Step 2
      intEven = intEven + Mid(strRefID, x, 1)
   Next x
' get digit for first letter of company name
   If Not (Mid(s, 1, 1) = Mid(strRefID, 4, 1)) Then
      isValidReregisterCode = False
   End If
' second digit of year
  ' strKey = strKey & Right(Format(Date, "yyyy"), 1)
' second digit of even total
   If Not (Val(Mid(s, 6, 1) & Mid(s, 3, 1)) = intEven) Then
      isValidReregisterCode = False
   End If
' first digit of odd total
   If Not (Val(Mid(s, 4, 1) & Mid(s, 9, 1)) = intOdd) Then
      isValidReregisterCode = False
   End If
' first digit of year
  ' strKey = strKey & Mid(Format(Date, "yyyy"), 3, 1)
' first digit of even total
  ' strKey = strKey & Left(strEven, 1)
' second digit of month
  ' strKey = strKey & Right(Format(Date, "mm"), 1)
' first digit of month
  ' strKey = strKey & Left(Format(Date, "mm"), 1)
' second digit of odd total
  ' strKey = strKey & Right(strOdd, 1)
' get digit for second letter of company name
   If Not (Mid(s, 10, 1) = Mid(strRefID, 2, 1)) Then
      isValidReregisterCode = False
   End If
   If isValidReregisterCode = True Then
      isValidReregisterCode = CheckDateReregister(strCode)
   End If
End Function

Public Function CheckDateKey(strName As String) As Boolean
   Dim m As String
   Dim y As String
   
   CheckDateKey = True
   m = Mid(strName, 12, 1) & Mid(strName, 14, 1)
   y = Mid(strName, 15, 1) & Mid(strName, 16, 1)
   m = m - Mid(strName, 13, 1)
   y = y - Mid(strName, 13, 1)
   CheckDateKey = canOpenWithStartDate(m, y)
End Function
            
Public Function CheckDateReregister(strName As String) As Boolean
   Dim m As String
   Dim y As String
   
   CheckDateReregister = True
   m = ReregisterDigit(Mid(strName, 8, 1)) & ReregisterDigit(Mid(strName, 7, 1))
   y = ReregisterDigit(Mid(strName, 5, 1)) & ReregisterDigit(Mid(strName, 2, 1))
   CheckDateReregister = canOpenWithStartDate(m, y)
End Function

Public Function canOpenWithStartDate(strMM As String, strYY As String) As Boolean
   Dim m As Integer
   Dim y As Integer
   Dim oM As Integer
   Dim oY As Integer
' assume that normal mm and yy date gets passed in
   canOpenWithStartDate = True
   oM = Val(strMM)
   oY = Val(strYY)
   m = Val(Format(Date, "mm"))
   y = Val(Right(Format(Date, "yyyy"), 2))
   If y = oY Then
      If m > (oM + 6) Then
         MsgBox "Your registration code has expired!  Please contact your distributor!"
         canOpenWithStartDate = False
      Else
         If m > (oM + 4) Then
            MsgBox "A new registration code will be required shortly!  Please contact your distributor!  You only have a short time to do so!"
         End If
      End If
   Else
      If (m + 12) > (oM + 6) Then
         MsgBox "Your registration code has expired!  Please contact your distributor!"
         canOpenWithStartDate = False
      Else
         If (m + 12) > (oM + 4) Then
            MsgBox "A new registration code will be required shortly!  Please contact your distributor!  You only have a short time to do so!"
         End If
      End If
   End If
End Function

Public Function ReregisterDigit(strCharacter As String) As String
   strCharacter = UCase(strCharacter)
   Select Case strCharacter
      Case "G"
         ReregisterDigit = 0
      Case "Q"
         ReregisterDigit = 0
      Case "P"
         ReregisterDigit = 1
      Case "E"
         ReregisterDigit = 1
      Case "O"
         ReregisterDigit = 2
      Case "S"
         ReregisterDigit = 2
      Case "F"
         ReregisterDigit = 3
      Case "B"
         ReregisterDigit = 3
      Case "W"
         ReregisterDigit = 4
      Case "N"
         ReregisterDigit = 4
      Case "H"
         ReregisterDigit = 5
      Case "U"
         ReregisterDigit = 5
      Case "T"
         ReregisterDigit = 6
      Case "K"
         ReregisterDigit = 6
      Case "C"
         ReregisterDigit = 7
      Case "D"
         ReregisterDigit = 7
      Case "Y"
         ReregisterDigit = 8
      Case "R"
         ReregisterDigit = 8
      Case "M"
         ReregisterDigit = 9
      Case "X"
         ReregisterDigit = 9
      Case Else
         ReregisterDigit = 0
   End Select
End Function