<%

' ADO constants used here '
' take from adovbs.inc (which is 500 lines long) '

'---- CursorTypeEnum Values ---- '
Const adOpenDynamic = 2

'---- LockTypeEnum Values ---- '
Const adLockOptimistic = 3

'---- CommandTypeEnum Values ---- '
Const adCmdText = &H0001
Const adCmdTable = &H0002

Dim oConn, oRS, oRS2, nRecs, gsADOErrors, gbDatabaseOpen, gbQueryOpen, gbDebugOn, gsSessionID, gsErrorMessage

gbDatabaseOpen = False
gbQueryOpen = False
gbDebugOn = False
gsSessionID = Session.SessionID
gsErrorMessage = ""

' (SS,30/09/03) special version for MySQL '
Sub OpenDatabase
  If gbDebugOn Then DebugLog("OpenDatabase called")
  ' open database if not already open '
  If Not gbDatabaseOpen Then
    Set oConn = Server.CreateObject("ADODB.Connection")
    oConn.ConnectionString = Application("ConnectionString")
    oConn.Open
    gbDatabaseOpen = True
    gsADOErrors = ""
  End If
End Sub

Sub CloseDatabase
  If gbDebugOn Then DebugLog("CloseDatabase called")
  If gbDatabaseOpen Then
    oConn.Close
    Set oConn = Nothing
    gbDatabaseOpen = False
  End If
End Sub

Sub OpenQuery(ASql)
  If gbQueryOpen Then CloseQuery ' if query already open then close it first '
  If gbDebugOn Then DebugLog("OpenQuery called with " & ASql)
  Set oRS = oConn.Execute(ASql, nRecs, adCmdText)
  gbQueryOpen = True
End Sub

Sub CloseQuery
  If gbDebugOn Then DebugLog("CloseQuery called")
  If gbQueryOpen Then
    oRS.Close
    Set oRS = Nothing
    gbQueryOpen = False
  End If
End Sub

Function EndOfQuery
  EndOfQuery = oRS.Eof
End Function

Sub NextQueryRecord
  oRS.MoveNext
End Sub

' (SS,10/10/01) '
Sub FirstQueryRecord
  oRS.MoveFirst
End Sub


' (SS,25/2/02) returns query value. Null is returned if field not found '
' useful when a crosstab query does not create an expected field '
Function GetQueryValueNullIfNotFound(AFieldName)
  GetQueryValueNullIfNotFound = Null
  On Error Resume Next
  GetQueryValueNullIfNotFound = oRS(AFieldName)
End Function

Function GetQueryValue(AFieldName)
  If gbDebugOn Then DebugLog("GetQueryValue called with " & AFieldName)
  GetQueryValue = oRS(AFieldName)
End Function


' (SS,3/10/01) '
Sub OpenQuery2(ASql)
  Set oRS2 = oConn.Execute(ASql, nRecs, adCmdText)
End Sub

Sub CloseQuery2
  oRS2.Close
  Set oRS2 = Nothing
End Sub

Function EndOfQuery2
  EndOfQuery2 = oRS2.Eof
End Function

Sub NextQueryRecord2
  oRS2.MoveNext
End Sub

Function GetQueryValue2(AFieldName)
  GetQueryValue2 = oRS2(AFieldName)
End Function

Sub ExecuteQuery(ASql)
 ' On Error Resume Next '
  If gbDebugOn Then DebugLog("ExecuteQuery called with " & ASql)
  oConn.Execute(ASql)
  CheckForADOErrors(oConn)
End Sub

' (SS,11/5/01)
Function CheckKeyExists(ATableName, AFieldName, AValue)
  Dim LoRS
  Set LoRS= oConn.Execute("SELECT * FROM " + ATableName + " WHERE " + AFieldName + "=" + AValue, nRecs, adCmdText)
  CheckKeyExists = not LoRS.Eof
  LoRS.Close
  set LoRS = Nothing
End Function

' (SS,15/5/01) '
Sub OpenTable(ATableName)
  If gbDebugOn Then DebugLog("OpenTable called")
  Set oRS = Server.CreateObject("ADODB.Recordset")
  oRS.Open ATableName, oConn, adLockOptimistic, adCmdTable
  'oRS.Open ATableName, oConn, 1, ,2 '
  ' rsProds.Open "products", strProvider, 1, , adCmdTable '
End Sub


' (SS,22/10/01) add because FindFirstRecord is too slow '
' opens recordset and find the record in ACriteria '
Sub OpenTableRecordForEdit(ATableName, ACriteria)
  Dim LSQL
  Set oRS = Server.CreateObject("ADODB.Recordset")
  LSQL = "SELECT * FROM " + ATableName + " WHERE " + ACriteria
  oRS.Open LSQL, oConn, adOpenDynamic, adLockOptimistic, adCmdText
End Sub


' (SS,15/5/01) '
Sub CloseTable
  If gbDebugOn Then DebugLog("CloseTable called")
 ' On Error Resume Next
  oRS.Close
  Set oRS = Nothing
 ' CheckForADOErrors(oConn)
End Sub

' (SS,15/5/01) must be a better and quicker way, using Locate, FindFirst or something '
' will it work in SQL? '
Function FindRecord(AFieldName, AValue)
  Dim LFound
  oRS.MoveFirst
  LFound = False
  Do Until oRS.EOF or LFound
    If oRS(AFieldName) & "" = AValue & "" then
      LFound = True
    Else
      oRS.MoveNext
    End If
  Loop
  FindRecord = LFound
End Function

' (SS,19/7/01) for ADO '
Function FindFirstRecord(ACriteria)
  oRS.Find ACriteria
  FindFirstRecord = Not oRS.EOF
End Function

' (SS,15/5/01) '
Sub EditRecord

End Sub

' (SS,15/5/01) '
Sub AddRecord
  oRS.AddNew
End Sub

' (SS,26/2/02) '
Function GetFieldValue(AFieldName)
  GetFieldValue = oRS(AFieldName)
End Function

' (SS,15/5/01) '
Sub PutFieldValue(AFieldName, AValue)
'  On Error Resume Next
  oRS(AFieldName) = AValue
'  CheckForADOErrors(oConn)
End Sub

' (SS,15/5/01) '
' (SS,3/10/01) added error handling '
Sub PostRecord
'  On Error Resume Next
  oRS.Update
'  CheckForADOErrors(oConn)
End Sub


' (SS,3/10/01) developed from Wrox ASP 3.0 page 349 '
' sets global gsADOError variable to "" of no error, else message '
Function CheckForADOErrors(objConn)
  Dim objError

  If objConn.Errors.Count > 0 Then

    ' loop through the errors
    For Each objError in objConn.Errors

      ' errors with number 0 are informational
      If objError.Number <> 0 Then
        gsADOErrors = gsADOErrors + objError.Description + vbCrLf
        CheckForADOErrors = True
      End If

    Next
  Else
    CheckForADOErrors = False
  End If

End Function


' Replace in String AStr, all occurrences of AReplace with AWith '
Function ReplaceStr(AStr, AReplace, AWith)
  Dim p, LStr
  ReplaceStr = ""
  LStr = AStr
  Do While LStr <> ""
    p = InStr(LStr, AReplace)
    If p > 0 Then
      ReplaceStr = ReplaceStr + Mid(LStr, 1, p - 1) + AWith
      LStr = Mid(LStr, p + Len(AReplace), Len(LStr))
    Else
      ReplaceStr = ReplaceStr + LStr
      LStr = ""
    End if
  Loop
End Function

' (SS,20/9/01) creates lookup combo from table
' (SS,17/12/01) added AOrderField parameter to allow ordering by other fields
' (SS,16/2/04) added ASelectName parameter which overrides AFieldName to give different name for select name
' (SS,17/2/04) added AExtras to add extra to the end e.g. disabled etc.
' (SS,19/2/04) added AWhereClause to do things like WHERE Country = "United Kingdom"
' (SS,21/5/04) if ATableName starts with "SELECT" then it is used as the full SQL
' (SS,25/11/04) added AValueField, if not blank then this Field will be used to get the Value for the combo instead of AFieldName
Function GetLookupCombo(ATableName, AFieldName, AOrderField, ADefaultValue, AShowBlank, ASelectName, AExtras, AWhereClause, AValueField)
  Dim s, strFieldValue, LSelectName, LShowBlank, LBlankValue, LValueValue

  LSelectName = AFieldName
  If ASelectName <> "" Then LSelectName = ASelectName

  ' (SS,28/10/04) changed so that class="form" is not added if AExtras contains class=, to allow class to be overriden '
  s = "<select name=""" + LSelectName + """"
  If InStr(LCase(AExtras), "class=") = 0 Then
    s = s + " class=""form"""
  End If
  If AExtras <> "" Then
    s = s + " " + AExtras
  End If
  s = s + ">"

  ' (SS,18/5/04) added following to allow special blank value to be passed '
  If VarType(AShowBlank) = vbBoolean Then
    LShowBlank = AShowBlank
    LBlankValue = ""
  Else
    LShowBlank = True
    LBlankValue = AShowBlank
  End If

  If LShowBlank Then
    If ADefaultValue = "" Then
      s = s + "<option value = """" selected>" & LBlankValue & "</option>"
    Else
      s = s + "<option value = """">" & LBlankValue & "</option>"
    End If
  End If

  If AOrderField = "" Then AOrderField = AFieldName

  ' (SS,21/5/04) if table name start with "SELECT " then use it has the SQL else build it from table name, where and order clauses '
  Dim LSQL
  If UCase(Left(ATableName, 7)) = "SELECT " Then
    LSQL = ATableName
  Else
    LSQL = "SELECT * FROM " + ATableName + Iif(AWhereClause = "", "", " WHERE " + AWhereClause) + " ORDER BY " + AOrderField
  End If

  OpenQuery(LSQL)
  Do While Not EndOfQuery
    strFieldValue = GetQueryValue(AFieldName)
    If AValueField = "" Then
      LValueValue = strFieldValue
    Else
      LValueValue = GetQueryValue(AValueField)
    End If
    s = s + "<option value=""" + LValueValue + """"
    If LValueValue = ADefaultValue Then s = s + " selected"
    s = s + ">" + strFieldValue + "</option>" + Chr(13) + Chr(10) ' Chr(13) + Chr(10) to made HTML more readable
    NextQueryRecord
  Loop
  CloseQuery
  s = s + "</select>"
  GetLookupCombo = s
End Function

' (SS,17/2/04) '
Function GetMonthCombo(ASelectName, ADefaultValue, ABlankValue)
  Dim s, i, m
  s = "<select name=""" + ASelectName + """ class=""form"">"
  s = s + "<option>" & ABlankValue & "</option>"
  For i = 1 to 12
    m = Right("0" & i, 2)
    If m = ADefaultValue Then
      s = s + "<option selected>"
    Else
      s = s + "<option>"
    End If
    s = s + m + "</option>" + Chr(13) + Chr(10)
  Next
  s = s + "</select>"
  GetMonthCombo = s
End Function

' (SS,17/2/04)
Function GetYearCombo(ASelectName, ADefaultValue, AStartYear, AEndYear, ABlankValue)
  Dim s, i, y
  s = "<select name=""" + ASelectName + """ class=""form"">"
  s = s + "<option>" & ABlankValue & "</option>"
  For i = AStartYear To AEndYear
    y = Right("000" & i, 4)
    If y = ADefaultValue Then
      s = s + "<option selected>"
    Else
      s = s + "<option>"
    End If
    s = s + y + "</option>" + Chr(13) + Chr(10)
  Next
  s = s + "</select>"
  GetYearCombo = s
End Function


' (SS,11/11/01) creates lookup combo from table, special version used to fill in values
' (SS,17/12/01) added AOrderField parameter to allow ordering by other fields
Function GetLookupFillCombo(ATableName, AFieldName1, AFieldName2, AFieldName3, AFieldName4, AOrderField, ADefaultValue, AShowBlank, AFunctionName)
  Dim s, strFieldValue
  s = "<select name=""u" + AFieldName1 + """ onchange=""" + AFunctionName + """>"
  If AShowBlank Then
    If ADefaultValue = "" Then
      s = s + "<option selected></option>"
    Else
      s = s + "<option></option>"
    End If
  End If

  If AOrderField = "" Then AOrderField = AFieldName1

  OpenQuery("SELECT * FROM " + ATableName + " ORDER BY " + AOrderField)
  Do While Not EndOfQuery
    strFieldValue = GetQueryValue(AFieldName1)
    If strFieldValue = ADefaultValue Then
      s = s + "<option selected>"
    Else
      s = s + "<option>"
    End If
    s = s + strFieldValue

    If AFieldName2 <> "" Then s = s & "; " & GetQueryValue(AFieldName2)
    If AFieldName3 <> "" Then s = s & "; " & GetQueryValue(AFieldName3)
    If AFieldName4 <> "" Then s = s & "; " & GetQueryValue(AFieldName4)

    s = s + "</option>" + Chr(13) + Chr(10) ' Chr(13) + Chr(10) to made HTML more readable
    NextQueryRecord
  Loop
  CloseQuery
  s = s + "</select>"
  GetLookupFillCombo = s
End Function


' (SS,19/10/01) yes no combo
Function GetYesNoCombo(AFieldName, ADefaultValue)
  Dim s
  s = "<select name=""" + AFieldName + """>" + Chr(13) + Chr(10)
  If ADefaultValue = "Yes" Then
    s = s + "<option>No</option>" + Chr(13) + Chr(10)
    s = s + "<option Selected>Yes</option>" + Chr(13) + Chr(10)
  Else
    s = s + "<option Selected>No</option>" + Chr(13) + Chr(10)
    s = s + "<option>Yes</option>" + Chr(13) + Chr(10)
  End If
  s = s + "</select>" + Chr(13) + Chr(10)
  GetYesNoCombo = s
End Function


' (SS,15/10/01) get access rights
Function GetAccessRights(AUserID, APassword)
  GetAccessRights = ""  ' default to no access rights

  OpenDatabase("Main")
  OpenQuery("SELECT * FROM Users WHERE UserID='" + AUserID + "' AND Password='" + APassword + "'")

  If Not EndOfQuery Then
    GetAccessRights = GetQueryValue("Rights")
  End If

  CloseQuery
  CloseDatabase
End Function

' (SS,15/10/01) get access rights
Function GetAccessLevel(AAccessRights)
  GetAccessLevel = 0  ' default to minimum access level

  OpenDatabase("Main")
  OpenQuery("SELECT * FROM Rights WHERE Rights='" + AAccessRights + "'")

  If Not EndOfQuery Then
    GetAccessLevel = GetQueryValue("AccessLevel")
  End If

  CloseQuery
  CloseDatabase
End Function

' (SS,25/10/01) change password
Function ChangePassword(AUserID, APassword, ANewPassword)
  ChangePassword = False  ' default to not successful

  OpenDatabase("Main")
  OpenTableRecordForEdit "Users", "UserID='" + AUserID + "' AND Password='" + APassword + "'"

  If Not EndOfQuery Then
    ChangePassword = True
    PutFieldValue "Password", ANewPassword
    PostRecord
  End If

  CloseTable
  CloseDatabase
End Function


Function Format2dp(ANumber)

  If IsNull(ANumber) Then
    Format2dp = Null
  Else
    Format2dp = FormatNumber(ANumber, 2, vbTrue, vbFalse, vbTrue)
  End If

End Function

' Immediate If function (SS,30/4/03)
Function IIf(a, b, c)
  If a Then IIf = b Else IIf = c
End Function

' (SS,21/2/02) returns null as zero, useful for calculations where null needs to be treated as zero
Function NZ(ANumber)
  If IsNull(ANumber) Then
    NZ = 0
  Else
    NZ = ANumber
  End If
End Function


' (SS,24/9/03)
' returns number followed by word
' e.g. PluralString(1, "product", "products") returns "1 product"
' for any other value it returns "x products"
Function PluralString(ANumber, AStringForOne, AStringForOther)
  If ANumber = 1 Then
    PluralString = ANumber & " " & AStringForOne
  Else
    PluralString = ANumber & " " & AStringForOther
  End If
End Function

' cleans the string, replacing quote and apostrophe with escape char
' also converts \ with \\ so it doesn't cause problems
' with SQL statements, works with MySQL, might not with other SQL Servers
' see MySQL manual page 432 (6.1.1.1)
Function CleanSQLStr(AValue)
  Dim LNewValue
  LNewValue = AValue
  LNewValue = Replace(LNewValue, "\", "\\")
  LNewValue = Replace(LNewValue, "'", "\'")
  LNewValue = Replace(LNewValue, """", "\""")
  CleanSQLStr = LNewValue
End Function

' (SS,26/6/04) '
' converts newlines to breaks for HTML '
Function ConvertNewlinesToHTML(AString)
  Dim LNewString
  If IsNull(AString) Then
    ConvertNewlinesToHTML = ""
    Exit Function
  End If
  LNewString = Replace(AString, Chr(13) & Chr(10), "<br>")
  ' newlines may also be as either Chr(10) & Chr(13), or either Chr(10) or Chr(13) '
  ' so all methods are tried '
  LNewString = Replace(LNewString, Chr(10) & Chr(13), "<br>")
  LNewString = Replace(LNewString, Chr(13), "<br>")
  LNewString = Replace(LNewString, Chr(10), "<br>")
  ConvertNewlinesToHTML = LNewString
End Function

' (SS,25/11/04) converts newlines to \n for Javascript alers '
Function ConvertNewlinesForJavascript(AString)
  Const JAVASCRIPT_NEWLINE = "\n"
  Dim LNewString
  If IsNull(AString) Then
    ConvertNewlinesForJavascript = ""
    Exit Function
  End If
  LNewString = Replace(AString, Chr(13) & Chr(10), JAVASCRIPT_NEWLINE)
  ' newlines may also be as either Chr(10) & Chr(13), or either Chr(10) or Chr(13) '
  ' so all methods are tried '
  LNewString = Replace(LNewString, Chr(10) & Chr(13), JAVASCRIPT_NEWLINE)
  LNewString = Replace(LNewString, Chr(13), JAVASCRIPT_NEWLINE)
  LNewString = Replace(LNewString, Chr(10), JAVASCRIPT_NEWLINE)
  ConvertNewlinesForJavascript = LNewString
End Function

' 6/10/03 runs a query and returns the value from given field, null is returned if no records found
Function GetValueFromQuery(AFieldName, ASQL)
  If gbDebugOn Then DebugLog("GetValueFromQuery called with " & AFieldName & ", " & ASQL)
  Dim LoRS
  Set LoRS = oConn.Execute(ASQL, nRecs, adCmdText)
  If LoRS.Eof Then
    GetValueFromQuery = Null
  Else
    GetValueFromQuery = LoRS(AFieldName)
  End If
  LoRS.Close
  Set LoRS = Nothing
End Function

' 6/10/03 gets value from settings table, null is returned if not found '
' TypeID is APP, EntryID is MAIN '
' SS,5/11/04 renamed from GetAppSetting '
' now also has MemoValue field as well as FieldValue '
' use GetAppSetting to get FieldValue, GetAppSettingMemo to get MemoValue '
Function GetAppSettingFromField(AGroupName, AFieldName, AValueField)
  If gbDebugOn Then DebugLog("GetAppSetting called with " & AGroupName & ", " & AFieldName)
  Dim LoRS
  Set LoRS = oConn.Execute("SELECT * FROM Settings WHERE TypeID = 'APP' AND EntryID = 'MAIN' AND GroupName = '" & AGroupName & "' AND FieldName = '" & AFieldName & "'", nRecs, adCmdText)
  If LoRS.Eof Then
    GetAppSettingFromField = Null
  Else
    GetAppSettingFromField = LoRS(AValueField)
  End If
  LoRS.Close
  Set LoRS = Nothing
End Function

' SS,5/11/04 see GetAppSettingFromField '
Function GetAppSetting(AGroupName, AFieldName)
  GetAppSetting = GetAppSettingFromField(AGroupName, AFieldName, "FieldValue")
End Function

' SS,5/11/04 see GetAppSettingFromField '
Function GetAppSettingMemo(AGroupName, AFieldName)
  GetAppSettingMemo = GetAppSettingFromField(AGroupName, AFieldName, "MemoValue")
End Function

' 6/10/03, save settings to settings table, the Group and Field must already exist '
' TypeID is APP, EntryID is MAIN '
Sub SetAppSetting(AGroupName, AFieldName, AFieldValue)
  If gbDebugOn Then DebugLog("SetAppSetting called with " & AGroupName & ", " & AFieldName)
  oConn.Execute("UPDATE settings SET FieldValue = '" & CleanSQLStr(AFieldValue) & "' WHERE TypeID = 'APP' AND EntryID = 'MAIN' AND GroupName = '" & AGroupName & "' AND FieldName = '" & AFieldName & "'")
End Sub

' shows the debug message, perhaps in the future add it to a log '
Sub DebugLog(ADebugMessage)
  Response.Write "*** " & ConvertNewlinesToHTML(ADebugMessage) & " ***<br><br>"
End Sub

' (SS,13/8/04) '
Sub DebugOn
  gbDebugOn = True
End Sub

' (SS,13/8/04) '
Sub DebugOff
  gbDebugOn = False
End Sub

' (SS,3/11/04) returns true if file exists '
Function FileExists(AFileName)
  Dim objFSO
  Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
  FileExists = objFSO.FileExists(AFileName)
  Set objFSO = Nothing
End Function

' (SS,3/11/04) deletes given file if it exists '
Sub DeleteFile(AFileName)
  Dim objFSO
  Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
  If FileExists(AFileName) Then objFSO.DeleteFile(AFileName)
  Set objFSO = Nothing
End Sub

' (SS,4/11/04) deletes given file if it exists '
Sub CopyFile(ASourceFileName, ADestinFileName)
  Dim objFSO
  Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
  If FileExists(ASourceFileName) Then objFSO.CopyFile ASourceFileName, ADestinFileName
  Set objFSO = Nothing
End Sub

' (SS,3/11/04) unlike Trim, this also removes all leading and trailing '
' chars of ' ' or less, Trim only does spaces '
' I wanted to use this to remove Chr(13) and Chr(10) chars '
Function TrimString(AString)
  Dim LString, i, LLen, LStart, LEnd
  LString = Trim(AString)

  LLen = Len(LString)
  If LLen = 0 Then
    TrimString = ""
    Exit Function
  End If

  ' find start of string '
  LStart = 1  ' set to start of string '
  For i = 1 To LLen
    If Mid(LString, i, 1) > " " Then
      LStart = i
      Exit For
    End If
  Next

  ' find end of string '
  LEnd = LLen  ' set to end of string '
  For i = LLen To 1 Step -1
    If Mid(LString, i, 1) > " " Then
      LEnd = i
      Exit For
    End If
  Next

  TrimString = Mid(LString, LStart, LEnd - LStart + 1)

End Function

' (SS,12/10/01) converts given date to UK string format, assumes regional setting on PC is UK '
Function GetUKDate(ADate)
  If IsNull(ADate) or ADate = "" Then
    GetUKDate = ""
  Else
   ' GetUKDate = DatePart("d", ADate) & "/" & DatePart("m", ADate) & "/" & DatePart("yyyy", ADate)
    GetUKDate = FormatDateTime(ADate, VbShortDate)
  End If
End Function

' (SS,12/10/01) converts given UK date in string to US date, assumes regional setting on PC is UK '
Function ConvertUKToUSDate(ADate)
  If IsNull(ADate) or ADate = "" Then
    ConvertUKToUSDate = Null ' because blank date can only be saved as Null not empty string '
  Else
    ConvertUKToUSDate = DatePart("m", ADate) & "/" & DatePart("d", ADate) & "/" & DatePart("yyyy", ADate)
  End If
End Function

' (SS,16/11/04) converts given UK date in string to MySQL format for us in SQL queries '
Function ConvertUKToMySQLDate(ADate)
  If IsNull(ADate) or ADate = "" Then
    ConvertUKToMySQLDate = Null ' because blank date can only be saved as Null not empty string '
  Else
    ConvertUKToMySQLDate = DatePart("yyyy", ADate) & "-" & DatePart("m", ADate) & "-" & DatePart("d", ADate)
  End If
End Function
%>