Attribute VB_Name = "DAOLib"

'DAOLIB.BAS - Utility subroutines to support DAO access to
'              data bases. Access and ODBC data bases are
'              supported.

Option Explicit

Global DataBaseName As String
Global DSN As String              'Data source name
Global Srvr As String             'Data base server name
Global dbUID As String            'Data base user name(Application is responsible)
Global dbPWD As String            'Data base user password(Application is responsible)
Global dbWSID As String           'Data base client computer name
Global wrkMain As Workspace
Global db As Database

Dim dbOpenDepth As Integer        'Private variable used by dbOpen, dbClose to keep
                                  'track of the open status of db. dbOpenDepth only
                                  'has meaning within the context of these two
                                  'subroutines. Use GetdbOpenDepth to find out what
                                  'the current value is.
Global Sql As String              'SQL string
Global Const dbReadOnly = True    'rdoOpenConnection argument, connection is read-only
Global Const dbReadWrite = False  'rdoOpenConnection argument, connection is read/write
Global Const dbBOOLEAN = 101  'Add-in rdo data type
Global Const dbCURRENCY = 102 'Add-in rdo data type
Global Const TypeEDITOR = 103   'Add-in rdo data type
Global dbTime As Single           'accumulated seconds of data base connection
Global dbOpens As Long            'number of data base opens
Global dbOpenTime As String       'time data base was last opened
Global ErCode As Long
Global ErStr As String
Global ErLine As Integer
Dim IdleCount As Long
Dim MyPath As String
Dim MyIniFileName As String
Private Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long
Private Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Private Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long

Sub AddField(Names, Values, fld, fldname, Typ)
'Construct/add to SQL statement parts to build an INSERT statement
'final statement form = INSERT into tablename(cstr(Names)) Values(Values)
  Select Case Typ
    Case dbChar, dbMemo
      Names = ConCat(CStr(Names), ",", CStr(fldname))
      Values = ConCat(CStr(Values), ",", dbEncloseString(CStr(fld)))
    Case dbNumeric, dbDecimal, dbInteger, dbLong, dbFloat, dbSingle, dbDouble, dbByte
      Names = ConCat(CStr(Names), ",", CStr(fldname))
      Values = ConCat(CStr(Values), ",", str((fld)))
    Case Else
      Err.Raise 999, "DataBase.AddField", "Undefined field type=" + str(Typ)
  End Select
End Sub

Private Function AddPath(s As String) As String 'Add path value to file name if not already specified

  If InStr(s, ":") = 0 And InStr(s, "\\") = 0 Then
    AddPath = MyPath + s              'no path given; add it
  Else
    AddPath = s                        'path already provided
  End If
End Function

Function AddWhere(Qry, TName, VName, Val1, Val2) 'Add Where clause to Qry
'TName = name of table
'VName = name of variable in table
'Val1  = lower limit or blank
'Val2  = upper limit
  If Trim(Val1) = "" Then
    If Trim(Val2) <> "" Then
      If Qry <> "" Then Qry = Qry + " and "
      Qry = Qry + TName + "." + VName + "<=" + dbEncloseString(Trim(Val2))
    End If
  Else
    If Qry <> "" Then Qry = Qry + " and "
    If Trim(Val2) = "" Then
      Qry = Qry + VName + "=" + dbEncloseString(Trim(Val1))
    Else
      Qry = Qry + VName + ">=" + dbEncloseString(Trim(Val1))
      Qry = Qry + " and " + VName + "<=" + dbEncloseString(Trim(Val2))
    End If
  End If
  AddWhere = Qry
End Function

Private Sub BldChange(ss, Sql As String, fld, fldname)
'Construct/add to SQL statement to build an UPDATE statement
'final statement form = UPDATE tablename SET Sql Where(...)
Dim Typ
  Typ = ss.Fields(fldname).Type
  Select Case Typ
    Case dbChar, dbMemo
      If Trim(fld) <> Trim(ss.Fields(fldname)) Then     'change found
        Sql = ConCat(Sql, ",", fldname + "=" + dbEncloseString(CStr(fld)))
      End If
    Case dbNumeric, dbDecimal, dbInteger, dbLong, dbFloat, dbSingle, dbDouble, dbByte
      If fld <> ss.Fields(fldname) Then     'change found
        Sql = ConCat(Sql, ",", fldname + "=" + str(fld) + "")
      End If
    Case Else
      Err.Raise 999, "DataBase.BldChange", "Undefined field type=" + str(Typ)
  End Select
End Sub

Private Function ChangeChar(s As String, C1 As String, C2 As String) As String 'Change all occurances of C1 with C2 in the string S.
  Dim ans As String                    'result string
  Dim l As Long                        'position of C1 in Lcl
  Dim Lcl As String                    'internal copy of S
  Lcl = s

  If Lcl <> "" Then
    l = InStr(Lcl, C1)
  Else
    l = 0
  End If

  While l <> 0
    ans = ans + Left$(Lcl, l - 1) + C2
    Lcl = Right$(Lcl, Len(Lcl) - (l - 1 + Len(C1)))
    l = InStr(Lcl, C1)
  Wend
  ChangeChar = ans + Lcl
End Function

Function ClnStr(ByVal varData As Variant) As String 'converts null or empty string into usable string
  If IsNull(varData) Then
    ClnStr = ""
  ElseIf IsEmpty(varData) Then
    ClnStr = ""
  Else
    ClnStr = Trim(CStr(varData))
  End If
End Function

Private Function ConCat(S1 As String, Sep As String, S2 As String) As String 'returns S1+Sep+S2 if S2 <> "", otherwise returns S1; if S1 = "" returns S2

  If Trim(S2) <> "" Then

    If S1 = "" Then
      ConCat = S2
    Else
      ConCat = S1 + Sep + S2
    End If
  Else
    ConCat = S1
  End If
End Function

Sub dbClose()
Dim s As String
  If dbOpenDepth <= 0 Then MsgBox "Excess dbClose call; dbOpenDepth=" + CStr(dbOpenDepth)
  dbOpenDepth = dbOpenDepth - 1 'reduce depth(protected)
  If dbOpenDepth = 0 Then                   'close only when back at top
    If Not db Is Nothing Then
      db.Close
      dbTime = dbTime + DateDiff("s", dbOpenTime, Now)
      dbOpenTime = ""
      Set db = Nothing
    End If
  End If
End Sub

Function dbCreateResultSet(Sql, rs) As Boolean
1      Dim Tries
2      Const TriesConstant = 10
3      On Error GoTo HandleTheError
4      Tries = TriesConstant
5      Set rs = Nothing
6      While Tries > 0 And rs Is Nothing
7          Set rs = db.OpenRecordset(Sql, , , dbExecDirect)
8          Tries = Tries - 1
9      Wend
10     If Tries <> TriesConstant - 1 Then Err.Raise 999, "dbCreateResultSet tries=" + str(TriesConstant - Tries)
11     If Not rs Is Nothing Then dbCreateResultSet = True
12     '{AWHTE
13     Exit Function
HandleTheError:
14     Err.Raise 999, "DATABASE.dbCreateResultSet" + dbGetError
15     Exit Function
16     'AWHTE}
End Function

Function dbEncloseString(s As String) As String
' Enclose the string item S in apostrophes. Change any embedded appostrophe's to
' double aphostrophes
Const Container = "'"
  dbEncloseString = Container + ChangeChar(s, "'", "''") + Container 'return our result
End Function

Function dbExecute(db As Database, s As String) As Long
1      ' Execute SQL statement S on data base DB. If C <> "" use
2      ' Execute to perform, otherwise use Execute
3      On Error GoTo HandleTheError
4      Call db.Execute(s, dbExecDirect)
5      dbExecute = db.RecordsAffected
6      '{AWHTE
7      Exit Function
HandleTheError:
8      Err.Raise 999, "DATABASE.dbExecute:" + dbGetError
9      Exit Function
10     'AWHTE}
End Function

Function dbFieldExists(db, TIndx As Integer, N As String) As Integer
' Search for a field named 'N' in data base 'Db' in the table at TIndx. Return the index of
' the field if found; otherwise return -1.
Dim ans As Integer
Dim i As Integer
  dbFieldExists = -1                            'initial result is not found
  If db Is Nothing Then Exit Function
  For i = 0 To db.TableDefs(TIndx).Fields.Count - 1 'loop through tables in data base
    If InStr(UCase$(db.TableDefs(TIndx).Fields(i).Name), UCase$(N)) <> 0 Then 'found match
      ans = i                         'set result
      i = db.TableDefs(TIndx).Fields.Count   'force end of loop
    End If
  Next 'I
  dbFieldExists = ans                 'return the answer
End Function

Function dbGetError() As String 'retrieve database error information
Dim Msg As String
  ErCode = Err
  ErStr = Error
  ErLine = Erl
  Msg = "Error "
  If ErLine <> 0 Then Msg = Msg + "at Line" + str(Erl) + " "
  If ErCode < 32768 Or ErCode >= 50000 Then
    Msg = Msg + str(ErCode) + " " + ErStr
  Else
    If Sql <> "" Then Msg = ConCat(Msg, vbCrLf, "SQL=" + Sql)
  End If
  dbGetError = Msg
End Function

Function dbGetNumbRecs(rs) As Long
'Get number of records in result set rs
Dim rw As Long
  On Error GoTo dbGNRErr
  rw = rs.RowCount               'save current row position
  If Not rs.EOF Then rs.MoveLast 'move to the last row
  dbGetNumbRecs = rs.RowCount    'set return argument
  If rw <> rs.RowCount Then      'need to reposition back where we were
    If rw = 0 Then
      rs.MoveFirst               'go back to the beginning
    ElseIf rw <> rs.RowCount Then
      rs.Move (rs.RowCount - rw) 'go back to the record we were on
    End If
  End If
  GoTo dbGNREnd
dbGNRErr:
'just return because row count is non critical
  dbGetNumbRecs = -1
  Resume dbGNREnd
dbGNREnd:
End Function

Function dbOpen(rw) As Integer 'open database
    Dim s As String
    Dim odbcDSN As String
    Dim Inx As Integer    'index into Cnct
    Dim Cnct As String    'connect string
    Dim T As String
    Dim FilePath As String
    Dim FileNameShort As String
    Dim FileNameLong As String
    Dim Ext As String
    Dim ShortDatabaseName As String
    Dim l As Integer
    Dim ans As String * 255
    IdleCount = 0                      'reset idle counter
    dbOpenDepth = dbOpenDepth + 1      'increase depth
    If Not db Is Nothing Then          'open only performed at initial request
        dbOpen = True
        Exit Function
    End If
    On Error GoTo BaddbOpen
    dbOpen = False
    dbOpenTime = Now
    If InStr(DataBaseName, ".") <> 0 Then
        Call FSplitLong(DataBaseName, FilePath, FileNameShort, FileNameLong, Ext)
        ShortDatabaseName = FilePath + FileNameShort + Ext
        If InStr(UCase$(ShortDatabaseName), ".MDB") Then
            If wrkMain Is Nothing Then
                Set wrkMain = CreateWorkspace("JetWorkSpace", "Admin", "", dbUseJet)    'Create odbc Workspace object.
            End If
        ElseIf InStr(UCase$(ShortDatabaseName), ".XLS") Then
            s = "DataBase=" + ShortDatabaseName + ";DBQ=" + ShortDatabaseName + ";DefaultDir=" + App.Path + "\;Driver={Microsoft Excel Driver (*.xls)};DriverId=790;FIL=excel 5.0;ImplicitCommitSync=Yes;MaxBufferSize=512;MaxScanRows=8;PageTimeout=5;ReadOnly=0;SafeTransactions=0;Threads=3;UID=admin;UserCommitSync=Yes;"
        Else
            MsgBox "Data base " + DataBaseName + " cannot be accessed by this program (Unsupported).", vbCritical, "Oops!"
            Exit Function
        End If
        Set db = wrkMain.OpenDatabase(ShortDatabaseName, dbDriverNoPrompt, rw)
    Else
        If DSN <> "" Then
          ans = ""
          l = GetPrivateProfileString(ByVal DSN, ByVal "Driver", ByVal "", ans, Len(ans), "ODBC.INI")
          odbcDSN = Left$(ans, l)
        End If
        If dbWSID = "" Then dbWSID = App.EXEName
        s = "ODBC;DRIVER=SQL Server;SERVER=" + Srvr + ";DATABASE=" + DataBaseName + ";APP=Visual Basic; WSID=" + dbWSID 'construct connect string
        If dbUID <> "" Then
            s = s + "; UID=" + dbUID   'add user name if present
            If dbPWD <> "" Then
                s = s + "; PWD=" + dbPWD  'add password if present
            End If
        End If
        'S = S + ";DSN="
        If Srvr <> "" Then
            Set db = DBEngine.Workspaces(0).OpenDatabase(DSN, dbDriverNoPrompt, rw, s)
        ElseIf DSN = "" Or odbcDSN = "" Then 'DSN not supplied or not found in ODBC.INI
            'Set db = wrkMain.OpenDatabase(DSN, dbDriverPrompt, rw, S)
            Set db = DBEngine.Workspaces(0).OpenDatabase(DSN, dbDriverPrompt, rw)
            Cnct = db.Connect 'retrieve connect string
            Inx = InStr(Cnct, "DSN=")
            If Inx <> 0 Then
                Cnct = Right$(Cnct, Len(Cnct) - (Inx + 3))
                Inx = InStr(Cnct, ";")
                DSN = Left$(Cnct, Inx - 1)
                Call PutProfileText("DataBase", "DSN", DSN)
            End If
        Else
            Set db = DBEngine.Workspaces(0).OpenDatabase(DSN, dbDriverNoPrompt, rw, s)
        End If
    End If
    dbOpen = True
    dbOpens = dbOpens + 1
    Exit Function
BaddbOpen:
    ErStr = "DataBase.dbOpen:" + dbGetError
    Err.Raise 999, ErStr
    dbOpenTime = ""
    dbOpenDepth = dbOpenDepth - 1      'reverser prior depth increase
End Function

Function dbTableExists(db, N As String) As Integer
    ' Search for a table named 'N' in data base 'Db'. Return the index of
    ' the table if found; otherwise return -1.
    Dim ans As Integer
    Dim i As Integer
    dbTableExists = -1                          'initial result is not found
    If db Is Nothing Then Exit Function
    For i = 0 To db.TableDefs.Count - 1 'loop through tables in data base
        If InStr(UCase$(db.TableDefs(i).Name), UCase$(N)) <> 0 Then 'found match
            ans = i                       'set result
            i = db.TableDefs.Count        'force end of loop
        End If
    Next 'I
    dbTableExists = ans               'return the answer
End Function

Function dbTypeOf(cl As Field) As String
Dim txt As String
  Select Case cl.Type
    Case dbByte
      txt = "Byte"
    Case dbInteger
      txt = "Int"
    Case dbLong
      txt = "Long"
    Case dbSingle
      txt = "Single"
    Case dbFloat, dbDouble
      txt = "Double"
    Case dbDate, dbTimeStamp
      txt = "Dte"
    Case dbChar, TypeEDITOR, 10
      txt = "Text"
    Case dbMemo
      txt = "Memo"
    Case dbBOOLEAN
      txt = "Boolean"
    Case dbCURRENCY, 5
      txt = "Currency"
    Case Else
      txt = "Unknown"
  End Select
  dbTypeOf = txt
End Function

Sub FSplit(str As String, FilePath As String, FileName As String, Ext As String)
'Split FileName into its parts
  Dim LName As String                  'local copy of FileName
  Dim i As Integer
  FileName = ""
  FilePath = ""
  Ext = ""
  LName = UCase$(str)
  i = InStr(LName, ".")

  If i <> 0 Then
    Ext = Right$(LName, Len(LName) - i + 1)
    LName = Left$(LName, i - 1)
  End If

  If InStr(LName, "\") = 0 Then
    FileName = LName
    Exit Sub                           'no path
  End If
  i = Len(LName)

  While i > 0 And Mid$(LName, i, 1) <> "\"
    i = i - 1
  Wend

  If i = 0 Then
    FileName = LName
  ElseIf i = Len(LName) Then
    FilePath = LName
  Else
    FilePath = Left$(LName, i)
    FileName = Right$(LName, Len(LName) - i)
  End If
End Sub

Sub FSplitLong(str As String, FilePath As String, FileNameShort As String, FileNameLong As String, Ext As String)
  Dim T As String
  Dim lt As Integer
  Call FSplit(str, FilePath, FileNameLong, Ext)
  T = Space(255)
  lt = Len(T)
  Call GetShortPathName(str, T, lt)
  T = ChangeChar(T, Chr$(0), " ")
  T = Trim(T)
  Call FSplit(T, FilePath, FileNameShort, Ext)
End Sub

Function GetdbOpenDepth() As Integer
  GetdbOpenDepth = dbOpenDepth
End Function

Function GetEqualsValue(Inp As Variant, Typ As Integer) As String
'Format Inp for use as a value to set or test against in SQL statement.
Dim V As String
  V = ""
  Select Case Typ                  'form value according to data type
    Case Is = dbBOOLEAN
      V = Inp
    Case Is = dbMemo
      V = dbEncloseString(CStr(Inp))
    Case dbByte, dbLong, dbInteger
      V = Inp
    Case dbSingle, dbFloat, dbDouble
      V = Inp
    Case Is = dbCURRENCY
      V = Inp
    Case Is = dbDate
      V = "#" + Inp + "#"
    Case Is = dbTime
      V = "#" + Inp + "#"
    Case Is = dbTimeStamp
      V = "#" + Inp + "#"
    Case Is = dbChar, TypeEDITOR
      V = dbEncloseString(CStr(Inp))
    Case Else
      V = Inp
  End Select
  GetEqualsValue = V
End Function

Private Function GetProfileText(PName As String, ItemName As String, Default As String) As String
  Dim ans As String * 255
  Dim Result As Integer
  ans = ""

  Result = GetPrivateProfileString(ByVal PName, ByVal ItemName, ByVal Default, ans, Len(ans), MyIniFileName)
  ans = (Left$(ans, Result))
  If Trim(ans) = "" Then ans = Default
  GetProfileText = Trim(ans)
End Function

Private Sub PutProfileText(Sect As String, Item As String, V As String) 'Write string 'V' to the .ini file in section 'Sect' with the name 'Item'
  Dim Result As Integer
  Result = WritePrivateProfileString(ByVal Sect, ByVal Item, ByVal V, MyIniFileName)
End Sub

Private Function RemoveMyPath(s As String) As String

'If S begins with MyPath, return S with MyPath removed.
'Using this with .ini files, allows them to be moved to new
'directories without change as long as the associated data files are in
'the same directory as the program.
  If InStr(UCase$(s), UCase$(MyPath)) = 1 Then
    RemoveMyPath = Right$(s, Len(s) - Len(MyPath))
  Else
    RemoveMyPath = s
  End If
End Function

Sub GetProfile_DataBase(Path, IniFile) 'retrieve [DataBase] parameters
Dim s As String
  MyPath = Path
  MyIniFileName = IniFile
  DataBaseName = GetProfileText("DataBase", "DataBaseName", "")
  If InStr(DataBaseName, ".") <> 0 Then
    DataBaseName = AddPath(DataBaseName)
  End If
  s = " DataBaseName=" + DataBaseName
  DSN = GetProfileText("DataBase", "DSN", "")
  s = s + " DSN=" + DSN
  Srvr = GetProfileText("DataBase", "SRVR", "")
  s = s + " SRVR=" + Srvr
  Call PutProfile_DataBase
  dbTime = 0               'accumulated seconds of data base connection
  dbOpens = 0              'number of data base opens
  dbOpenDepth = 0          'initialize
End Sub

Private Sub PutProfile_DataBase()
  Call PutProfileText("DataBase", "DataBaseName", RemoveMyPath(DataBaseName))
  Call PutProfileText("DataBase", "DSN", DSN)
  Call PutProfileText("DataBase", "SRVR", Srvr)
End Sub