ODBCDirect is no longer supported.

Option Compare Database
Option Explicit

Public gstrDatabase As String
Public gstrUID As String
Public gstrPWD As String
Public gstrDSN As String
Public gstrTableList As String
Public gintLinkCount As Integer
Public gintReportImportCount As Integer
Public gstrPRMNames() As String
Public gIsRelationshipsDirty As Boolean
Public wrkODBC As Workspace
Public dbsProsper As Database
Public ThisMDB As Database
Function AddAppProperty(strName As String, varType As Variant, varValue As Variant) As Integer
    Dim dbs As Object, prp As Variant
    Const conPropNotFoundError = 3270

    Set dbs = CurrentDb
    On Error GoTo AddProp_Err
    dbs.Properties(strName) = varValue
    AddAppProperty = True

AddProp_Bye:
    Exit Function

AddProp_Err:
    If Err = conPropNotFoundError Then
        Set prp = dbs.CreateProperty(strName, varType, varValue)
        dbs.Properties.Append prp
        Resume
    Else
        AddAppProperty = False
        Resume AddProp_Bye
    End If
End Function

'This is the starting point of this application:
'Confirms connection to Prosper database (links tables if necessary)
'Checks for any reports to import in same directory, and then opens form "frmReports"
Function StartUp()
    On Error GoTo StartUpError
    Dim strTempTable As String, i As Integer, varReturn As Variant
    'Stop
    'Minimize the Database window
    DoCmd.Minimize
    'Stop
    Dim intX As Integer
    Const DB_Text As Long = 10
    intX = AddAppProperty("AppTitle", DB_Text, "Touché Report Manager")
    
    Application.RefreshTitleBar

    '
    gIsRelationshipsDirty = False
    'Display message  "Connecting to Prosper database..." in status bar
    varReturn = SysCmd(acSysCmdSetStatus, "Connecting to Prosper database..." & strTempTable)
     
    'Create an instance of this Access database object
    Set ThisMDB = CurrentDb
    
    'Get location of Prosper.ini from Command Line
    If UCase((Right$(Command, 4))) <> ".INI" Then
        MsgBox "You do not have permission to run this program."
        Quit
    ElseIf Dir(Command) = "" Then
        'Check that the file Prosper.ini exists
        MsgBox "File: " & Command & " not found!"
        Quit
    End If
    
    'Read Data properties from Prosper.ini into global variables
    CGeneral.IniPath = Command
    gstrUID = CGeneral.IniRead("Data Source", "Network UID")
    gstrPWD = CGeneral.IniRead("Data Source", "Network PWD")
    gstrDSN = CGeneral.IniRead("Data Source", "Network DSN")
    gstrTableList = CGeneral.IniRead("PRM", "TableList1")
    gstrTableList = gstrTableList & CGeneral.IniRead("PRM", "TableList2")
    
    'Validate the properties that were just read from Prosper.ini
    If gstrTableList = "" Then
        MsgBox "Invalid INI file setting for 'TableList'"
        Quit
    ElseIf gstrUID = "" Then
        MsgBox "Invalid INI file setting for 'Network UID'"
        Quit
    ElseIf gstrDSN = "" Then
        MsgBox "Invalid INI file setting for 'Network DSN'"
        Quit
    End If
    
    Set wrkODBC = CreateWorkspace("NewODBCWorkspace", "admin", "", dbUseODBC)
    
    'Open READ-ONLY connection object based on information entered in DSN.
    Set dbsProsper = wrkODBC.OpenConnection("ProsperWorkspace", _
        dbDriverNoPrompt, True, "ODBC;UID=" & gstrUID & ";PWD=" & gstrPWD & ";DSN=" & gstrDSN & ";")
    
    'Link or Re-link all tables specified in gstrTableList if any are unattached or DSN is changed
    i = 1
    Do
        strTempTable = CGeneral.ParseString(gstrTableList, ",", i)
        varReturn = SysCmd(acSysCmdSetStatus, "Linking Table " & strTempTable)
        If strTempTable <> "" Then
            LinkTable strTempTable
            i = i + 1
        End If
    Loop Until strTempTable = ""
    
    'Close Temporary workspace/database object
    dbsProsper.Close: Set dbsProsper = Nothing
    wrkODBC.Close: Set wrkODBC = Nothing
    
    'If any table was relinked in LinkTable(), then re-create all table relationships
    
    If gIsRelationshipsDirty = True Then
        varReturn = SysCmd(acSysCmdSetStatus, "Recreating Relationships...")
        RecreateRelationships
    End If
    
    
    'Display no. of tables actually linked (if any):
    If gintLinkCount > 0 Then
        'MsgBox gintLinkCount & " tables were linked or re-linked!"
    End If
   
    'Check for and import any reports from any previous version of PRM database
     ImportReports
    
    DoCmd.OpenForm "frmReports"
    
    'Clear the Status Bar
    varReturn = SysCmd(acSysCmdClearStatus)
    
    'Lock the Database
    LockDB (True)
            
    'Remove instance of this Database object
    Set ThisMDB = Nothing

    Exit Function

StartUpError:
    If Err.Number = 68 Then
        MsgBox "Error in StartUp(): ODBC is database currently unavailable"
    Else
        MsgBox "Error in StartUp():" & vbCrLf & Err.Description
    End If
End Function

Sub RecreateRelationships()
    On Error Resume Next
    Dim rln As Relation, fld As Field
    Dim rst As Recordset
    
    'Stop
    
    'Delete any leftover relationships
    For Each rln In ThisMDB.Relations
        ThisMDB.Relations.Delete rln.Name
    Next
    
    'Open Relationships table
    Set rst = ThisMDB.OpenRecordset("Relationships")
    rst.MoveFirst
    
    'Loop through Relationships table and create all
    'the pre-defined table relationships
    With rst
        Do While Not .EOF
            Set rln = ThisMDB.CreateRelation(!RelationshipName, !TableName, !ForeignTablename, !Attributes)
                Set fld = rln.CreateField(!FieldName)
                    fld.ForeignName = !ForeignFieldName
                    rln.Fields.Append fld
                    ThisMDB.Relations.Append rln
                Set fld = Nothing
            Set rln = Nothing
            .MoveNext
        Loop
        .Close
    End With

    'Clean up
    Set rst = Nothing
    Set rln = Nothing
    Set fld = Nothing
    
End Sub

Sub SaveRelationships()
    On Error Resume Next
    Dim rln As Relation, fld As Field
    Dim rst As Recordset

    'Stop
    
    'This refreshes the database (useful when testing):
    If Not ThisMDB Is Nothing Then
        Set ThisMDB = Nothing
    End If
    Set ThisMDB = CurrentDb
    
    'Exit if no relationships to save
    If ThisMDB.Relations.Count = 0 Then Exit Sub
    
    'Clear Relationships table
    ThisMDB.Execute ("Delete * From Relationships")
    
    'Open (now blank) Relationships table
    Set rst = ThisMDB.OpenRecordset("Relationships")
    
    'Loop through Relationships in database
    'and save all table relationships to Relationships table
    For Each rln In ThisMDB.Relations
        With rln
            For Each fld In .Fields
                rst.AddNew
                rst!RelationshipName = .Name
                rst!TableName = .Table
                rst!ForeignTablename = .ForeignTable
                rst!Attributes = .Attributes
                
                rst!FieldName = fld.Name
                rst!ForeignFieldName = fld.ForeignName
                rst.Update
            Next
        End With
    Next
    
    'Clean up
    rst.Close
    Set rst = Nothing
    Set rln = Nothing
    Set fld = Nothing
End Sub

'Used by Sub LinkTable() to check if a table is already linked:
'Returns True only if strTableName is the name of an exisiting table
Public Function TableExists(strTableName As String) As Boolean
    On Error Resume Next
    Dim tdfLinked As TableDef, i As Integer
    TableExists = False
    With CurrentDb
        If .TableDefs.Count > 0 Then
            For i = 0 To .TableDefs.Count - 1
                If strTableName = .TableDefs(i).Name Then
                    TableExists = True
                    Exit For
                End If
            Next
        End If
    End With
End Function

'Used by Sub Startup() to link tables from the Prosper database
Public Function LinkTable(strTableName As String)
    On Error GoTo LinkError
    Dim tdfLinked As TableDef, strDSN As String, intDSNpos As Integer
   
   'Stop
   
    'Link table (If already linked, refresh link)
    If TableExists(strTableName) = True Then
        
        Set tdfLinked = ThisMDB.TableDefs(strTableName)
        With tdfLinked
            
            'Check for a different DSN to the one in the attached table
            'in case the user points to a different database via the Prosper ini file:
            intDSNpos = InStr(1, .Connect, "DSN=")
            If intDSNpos > 0 Then
                intDSNpos = intDSNpos + 4
                strDSN = Mid$(.Connect, intDSNpos, InStr(intDSNpos, .Connect, ";") - intDSNpos)
            End If
        End With
            
        'If current table is attached to an SQL server and the supplied DSN is a another SQL server database, OR
        'The currently attached database is Access and the supplied DSN is SQL server, OR
        'The currently attached database is SQL Server and the supplied DSN is Access, OR
        'Both databases are Access, but different MDB files; then,
        'Unattach the current table and attach a new one from supplied DSN
        '(When attaching, check new db for type = Access or SQL server and attach via jet or ODBC respectively)
        If (strDSN <> "" And strDSN <> gstrDSN) Or _
           (strDSN = "" And InStr(1, dbsProsper.Connect, ".mdb") = 0) Or _
           (strDSN <> "" And InStr(1, dbsProsper.Connect, ".mdb") > 0) Or _
           (strDSN = "" And InStr(1, dbsProsper.Connect, ".mdb") > 0 And _
             (GetConnectParam(tdfLinked.Connect, "DATABASE") <> GetConnectParam(dbsProsper.Connect, "DBQ"))) Then
            
            'Delete (Connection of) linked table
            ThisMDB.TableDefs.Delete strTableName
            Set tdfLinked = Nothing

            'Recreate table
            Set tdfLinked = ThisMDB.CreateTableDef(strTableName)
                        
            'If the supplied DSN is Access (not SQL server) then
            'don't connect via ODBC, connect via Jet...
            If Left(dbsProsper.Connect, 5) = "ODBC;" And InStr(1, dbsProsper.Connect, ".mdb") Then
                'Use Jet to connect
                tdfLinked.Connect = ";DATABASE=" & GetConnectParam(dbsProsper.Connect, "DBQ")
            Else
                'Use ODBC to connect
                tdfLinked.Connect = dbsProsper.Connect
                tdfLinked.Attributes = dbAttachSavePWD
            End If
            
            tdfLinked.SourceTableName = strTableName
            ThisMDB.TableDefs.Append tdfLinked
            
            'Set global gIsRelationshipsDirty variable so that all
            'table relationships will later get recreated
            gIsRelationshipsDirty = True
            gintLinkCount = gintLinkCount + 1
        End If
        
        Set tdfLinked = Nothing
    Else
        ' Create a link that points to a table in Prosper SQL Server database.
        Set tdfLinked = ThisMDB.CreateTableDef(strTableName)
        With tdfLinked
            'If the Prosper ODBC database is Access (not SQL server) then
            'don't connect via ODBC, connect via Jet...
            If Left(dbsProsper.Connect, 5) = "ODBC;" And InStr(1, dbsProsper.Connect, ".mdb") Then
                .Connect = ";DATABASE=" & GetConnectParam(dbsProsper.Connect, "DBQ")
            Else
                .Connect = dbsProsper.Connect
                .Attributes = dbAttachSavePWD
            End If
            
            .SourceTableName = strTableName
            ThisMDB.TableDefs.Append tdfLinked
        End With
        
        Set tdfLinked = Nothing
        gintLinkCount = gintLinkCount + 1
    End If

    Exit Function
    
LinkError:
        MsgBox "Error linking table: " & strTableName & vbCrLf & Err.Description
        
        If Not tdfLinked Is Nothing Then
            Set tdfLinked = Nothing
            Set ThisMDB = Nothing
        End If
        
        End
End Function

'Reads a parameter from a connection string (which are normally terminated with a semicolon or nothing at end of string)
'Eg: GetConnectParam("ODBC;Database=C:\MyDb;UID=Admin", "Database") returns C:\MyDb
Function GetConnectParam(strConnect As String, strParam As String) As String
    On Error Resume Next
    Dim intParamPos As String
    intParamPos = InStr(1, strConnect, strParam) + Len(strParam) + 1 'the 1 is for the '=' sign
    If intParamPos > 0 Then
        
        'If this is the last paramaeter, it may not be semicolon terminated
        'in which case read to the end of string
        If InStr(intParamPos, strConnect, ";") = 0 And intParamPos < Len(strConnect) Then
            GetConnectParam = Mid$(strConnect, intParamPos)
        Else
            'else read to 1 character before the next semicolon
            GetConnectParam = Mid$(strConnect, intParamPos, InStr(intParamPos, strConnect, ";") - intParamPos)
        End If
    Else
        GetConnectParam = ""
    End If
End Function

'Used by form frmReports and Sub Startup() to lock and unlock this database:
Sub LockDB(blnLock As Boolean)
    On Error Resume Next
    If blnLock = True Then
        ChangeProperty "StartupShowDBWindow", dbBoolean, False
        ChangeProperty "AllowBreakIntoCode", dbBoolean, False
        ChangeProperty "AllowSpecialKeys", dbBoolean, False
        ChangeProperty "AllowBypassKey", dbBoolean, False
        'ChangeProperty "StartupShowStatusBar", dbBoolean, False
        'ChangeProperty "AllowBuiltinToolbars", dbBoolean, False
        'ChangeProperty "AllowFullMenus", dbBoolean, False
    Else
        ChangeProperty "StartupShowDBWindow", dbBoolean, True
        ChangeProperty "AllowBreakIntoCode", dbBoolean, True
        ChangeProperty "AllowSpecialKeys", dbBoolean, True
        ChangeProperty "AllowBypassKey", dbBoolean, True
        'ChangeProperty "StartupShowStatusBar", dbBoolean, True
        'ChangeProperty "AllowBuiltinToolbars", dbBoolean, True
        'ChangeProperty "AllowFullMenus", dbBoolean, True
    End If
End Sub

'Used by Sub LockDB() to change database properties:
Function ChangeProperty(strPropName As String, varPropType As Variant, varPropValue As Variant) As Integer
    Dim dbs As Database, prp As Property
    Const conPropNotFoundError = 3270

    Set dbs = CurrentDb
    On Error GoTo Change_Err
    dbs.Properties(strPropName) = varPropValue
    ChangeProperty = True

Change_Exit:
    Exit Function

Change_Err:
    If Err = conPropNotFoundError Then  ' Property not found.
        Set prp = dbs.CreateProperty(strPropName, _
                  varPropType, varPropValue)
        dbs.Properties.Append prp
        Resume Next
    Else
        ' Unknown error.
        ChangeProperty = False
        Resume Change_Exit
    End If
    
End Function

'Used by Sub Startup() to check for a previous version of PRM
'in the same direcory as this db. Any reports found in any database
'that matches "PRM*.mdb" will be presented for importing
'via form "frmImportReports"
Public Function ImportReports()
   ' Exit Function  ' who needs this any ways - often caused an error
    On Error GoTo Import_Error
    Dim strThisAppPath As String, i As Integer, strtemp As String
    Dim strThisAppName As String, strEarlierAppName As String
    'Reset counter for no of Reports imported
    gintReportImportCount = 0
    
    'If InStr(1, CurrentDb.Name, "PRM", vbTextCompare) = 0 Then
     '   MsgBox "This database (" & CurrentDb.Name & ") has been renamed!" & vbCrLf & _
     '   "The first 3 letters of any PRM database must be 'PRM'"
     '   Quit
    'Else
        strThisAppName = Mid$(CurrentDb.Name, InStr(1, CurrentDb.Name, "PRM", vbTextCompare))
    
    For i = 1 To 20
    
        If Left$(Right$(Command, i), 1) = "\" Then
        strThisAppPath = Left$(Command, Len(Command) - i + 1)
        i = 99
        End If
        
    Next i
   
    i = 0
    'Put path of all PRM databases into string array gstrPRMNames()
    strEarlierAppName = Dir(strThisAppPath & "PRM?????.MDB")
    If Len(strEarlierAppName) > 4 Then
    Do
        If strEarlierAppName <> "" Then
            If strEarlierAppName <> strThisAppName Then
                i = i + 1
                ReDim Preserve gstrPRMNames(1 To i) As String
                gstrPRMNames(i) = strThisAppPath & strEarlierAppName
            End If
        End If
        strEarlierAppName = Dir
    Loop Until strEarlierAppName = ""
    End If
    If i < 1 Then
        ImportReports = False
        Exit Function
    Else
        ImportReports = True
        DoCmd.OpenForm "frmImportReports", , , , , acDialog
    End If
    
    Exit Function
Import_Error:
    MsgBox "Error in ImportReports():" & vbCrLf & Err.Description
   
End Function

Select allOpen in new window