VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "RDOConnectMaster"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
'Standard class declarations
Private Declare Function GetPrivateProfileInt Lib "kernel32" Alias "GetPrivateProfileIntA" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal nDefault As Long, ByVal lpFileName As String) 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
Private ErStr         As String         'holds text for last error encountered
Private IAmADll       As Boolean        'TRUE if module is running as a DLL
Private IniRead       As Boolean        'TRUE if .ini file has been read
Private MyIniFileName As String         'location of my .ini file
Private MyPath        As String         'path where this code resides
'Class specific declarations
Private Const ModuleName = "RDOConn"
Public Enum OpenMode
  ReadOnly = True                       'rdoOpenConnection argument, connection is read-only
  ReadWrite = False                     'rdoOpenConnection argument, connection is read/write
End Enum
Private lConnect      As String         'Copy of the connect string
Private lDataBaseName As String         'Name of database
Private lOpenDepth    As Integer        'Variable used by dbOpen, dbClose to keep
'track of the open status of db. It only has
'meaning within the context of these two
'subroutines. Use property OpenDepth to find out
'what the current value is.
Private lOpenTime     As Date
Private lPWD          As String         'Data base user password
Private lSrvr         As String         'Server where database resides
Private lTime         As Long           'Seconds database was open
Private lUID          As String         'Data base user name
Private lWSID         As String         'Data base client computer name

Public Property Get Connect() As String
  Connect = lConnect
End Property

Public Property Get DataBaseName() As String
  DataBaseName = lDataBaseName
End Property

Public Property Let DataBaseName(ByVal NewDataBaseName As String)
  lDataBaseName = NewDataBaseName
End Property

Public Sub dbClose(db As rdoConnection)
1    On Error GoTo HandleTheError
3    If db Is Nothing Then Exit Sub
5    If lOpenDepth <= 0 And Not IAmADll Then
6      MsgBox "Excess dbClose call; lOpenDepth=" + CStr(lOpenDepth)
7    Else
8      lOpenDepth = lOpenDepth - 1         'reduce depth(protected)
9    End If
10   If lOpenDepth = 0 Then                'close only when back at top
11     If Not db Is Nothing Then
12       lTime = DateDiff("s", lOpenTime, Now)
13       lOpenTime = 0
14       Set db = Nothing
16     End If
17   End If
20   Exit Sub
HandleTheError:
21   Call ErrorMessage("RDOConn.dbClose")
End Sub

Public Function dbOpen(rw As OpenMode, db As rdoConnection) As Boolean
2    On Error GoTo HandleTheError
3    dbOpen = False
     If InStr(lDataBaseName, ".") <> 0 And Not Exists(lDataBaseName) Then
       ErStr = "RDOConn.dbOpen: " + lDataBaseName + " does not exist; database not opened."
       Exit Function
     End If
4    lOpenDepth = lOpenDepth + 1           'increase depth
6    If Not db Is Nothing Then             'open only performed at initial request
       dbOpen = True
8      Exit Function
9    End If
10   On Error GoTo BaddbOpen
11   lOpenTime = Now
12   If InStr(lDataBaseName, ".") <> 0 Then
14     If InStr(UCase$(lDataBaseName), ".MDB") Then
15       lConnect = "DataBase=" + lDataBaseName + ";DBQ=" + lDataBaseName + ";Driver=;Driver={Microsoft Access Driver (*.mdb)};DriverId=25;FIL=MS Access;ImplicitCommitSync=Yes;MaxBufferSize=512;MaxScanRows=8;PageTimeout=5;SafeTransactions=0;Threads=3;UserCommitSync=Yes"
16     ElseIf InStr(UCase$(DataBaseName), ".XLS") Then
17       lConnect = "DataBase=" + lDataBaseName + ";DBQ=" + lDataBaseName + ";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;"
18     Else
19       MsgBox "Data base " + lDataBaseName + " cannot be accessed by this program (Unsupported).", vbCritical, "Oops!"
20       Exit Function
21     End If
22     Set db = rdoEngine.rdoEnvironments(0).OpenConnection("", rdDriverNoPrompt, rw, lConnect)
23   Else
24     lConnect = "DRIVER={SQL Server};SERVER=" + lSrvr + ";DATABASE=" + lDataBaseName + ";APP=Visual Basic"
25     If lWSID <> "" Then lConnect = lConnect + "; WSID=" + lWSID
27     If lUID <> "" Then
28       lConnect = lConnect + "; UID=" + lUID 'add user name if present
29       If lPWD <> "" Then
30         lConnect = lConnect + "; PWD=" + lPWD 'add password if present
31       End If
32     End If
33     lConnect = lConnect + ";DSN="
34     If lSrvr <> "" Then
35       Set db = rdoEngine.rdoEnvironments(0).OpenConnection("", rdDriverNoPrompt, rw, lConnect)
36     Else
37       Set db = rdoEngine.rdoEnvironments(0).OpenConnection("", rdDriverPrompt, rw, lConnect)
38       lConnect = db.Connect
39     End If
40   End If
41   dbOpen = True
42   Exit Function
BaddbOpen:
43   Call ErrorMessage("RDOConn.dbOpen:")
45   lOpenTime = 0
46   lOpenDepth = lOpenDepth - 1           'reverse prior depth increase
48   Exit Function
HandleTheError:
49   Call ErrorMessage("RDOConn.dbOpen:")
End Function

Private Sub ErrorMessage(st)
  Dim er As rdoError
  Dim msg As String
  msg = st + "Error "
  If Erl <> 0 Then msg = msg + "at Line" + str(Erl) + " "
  If Err.Number < 32768 Or Err.Number >= 50000 Then
    msg = msg + str(Err.Number) + " " + ErStr
  Else
    For Each er In rdoErrors
      msg = msg + vbCrLf + str(er.Number) + " " + er.Description
    Next er
  End If
  ErStr = msg
End Sub

Public Property Get OpenDepth() As Integer
  OpenDepth = lOpenDepth
End Property

Public Property Get OpenTime() As Date
  OpenTime = lOpenTime
End Property

Public Property Get PWD() As String
  PWD = lPWD
End Property

Public Property Let PWD(ByVal NewPWD As String)
  lPWD = NewPWD
End Property

Public Property Get Srvr() As String
  Srvr = lSrvr
End Property

Public Property Let Srvr(ByVal NewSrvr As String)
  lSrvr = NewSrvr
End Property

Public Property Get Time() As Long
  Time = lTime
End Property

Public Property Get UID() As String
  UID = lUID
End Property

Public Property Let UID(ByVal NewUID As String)
  lUID = NewUID
End Property

Public Property Get WSID() As String
  WSID = lWSID
End Property

Public Property Let WSID(ByVal NewWSID As String)
  lWSID = NewWSID
End Property

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

Private Function ConditionPath(s)       'Guarantees trailing \ on path value S
  Dim ans As String
  ans = Trim(s)
  If ans = "\" Then ans = ""            'eliminate \ only
  If ans <> "" Then                     'prevent \ only
    If Right$(ans, 1) <> "\" Then ans = ans & "\"
  End If
  ConditionPath = ans
End Function

Public Property Get Error() As String   'Returns text describing last error occurrance. Use clears the stored text.
  Error = ErStr
  ErStr = ""
End Property

Private Function Exists(FileName As String) As Boolean 'Returns TRUE if FileName exists.
  On Error Resume Next
  Exists = Len(Dir$(FileName)) <> 0 And FileName <> ""
  If Err <> 0 Then Exists = False
End Function

Private Sub FormatError(SubName, ErrorNumber, Description, Optional ErrorLine As Integer = 0) 'Formats an error message as "ModuleName.SubName: ErrorNumber ErrorLine: Description"
  ErStr = ModuleName + "." + SubName + ": Error " + Trim(str(ErrorNumber))
  If ErrorLine <> 0 Then ErStr = ErStr + " at line " + Trim(str(ErrorLine))
  ErStr = ErStr + ": " + Description
End Sub

Private Sub FSplit(str As String, FilePath As String, FileName As String, Ext As String) 'Splits 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

Private Sub GetProfile()
  IniRead = True                        '.ini has been read
End Sub

Function GetProfileInt(PName As String, ItemName As String, Default As Long) As Long
  GetProfileInt = GetPrivateProfileInt(ByVal PName, ByVal ItemName, Default, MyIniFileName)
End Function

Private Function GetProfileText(PName As String, ItemName As String, Optional Default As String = "") As String 'Returns MyIniFileName contents from section [Pname] for item [ItemName]. Default provides a default value if nothing is found.
  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 Function GetStringArg(Arg, Def) As String 'Interprets string argument Arg and returns "", Def, or Arg depending on what is found in Arg (Null, "", or string)
  Dim ans As String
  If IsNull(Arg) Then                   'no value desired; return empty string
    ans = ""
  ElseIf Arg = "" Then                  'argument value not given; use default value
    ans = Def
  Else                                  'use supplied argument value
    ans = Arg
  End If
  GetStringArg = 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, returns S with MyPath removed. Otherwise returns S unchanged.
  '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

Public Sub SetupIni(APath As String, AnIniFile As String) 'Sets MyPath=APath and MyIniFileName=AnIniFile
  If APath <> "" Then MyPath = ConditionPath(APath)
  If AnIniFile <> "" Then MyIniFileName = AddPath(AnIniFile)
End Sub

Private Sub Class_Initialize()
  IAmADll = (App.StartMode = vbSModeAutomation) 'TRUE if we are operating as a DLL
  If IAmADll Then
    MyPath = App.Path + "\"
    MyIniFileName = MyPath + App.EXEName + ".ini"
  Else
  End If
  IniRead = False
  lConnect = ""
  lDataBaseName = ""
  lOpenDepth = 0
  lOpenTime = 0
  lPWD = ""
  lSrvr = ""
  lTime = 0
  lUID = ""
  lWSID = ""
End Sub