re-linking tables to another db, modified sample code 2

[simon551]

Can you help me figure out what I'm doing wrong. I've modified some code from the Solutions.mdb database provided by microsoft. It asks for the file path twice, seeming to run a part of the script twice. on the second selection, it works. Can't understand what I've done wrong. Here is my code:



Public Function RelinkTables() As Boolean
' Tries to refresh the links to the database.
' Returns True if successful.

Dim strAccDir As String
Dim strSearchPath As String
Dim strFileName As String
Dim intError As Integer
Dim strError As String

Const conMaxTables = 8
Const conNonExistentTable = 3011
Const conNottest1 = 3078
Const conNwindNotFound = 3024
Const conAccessDenied = 3051
Const conReadOnlyDatabase = 3027
Const conAppTitle = "Time & Expense Billing abc v.1.1"

' Get name of directory where MSAccess.exe is located.
strAccDir = SysCmd(acSysCmdAccessDir)

' Get the default sample database path.
If Dir("\\abc\data\abc_Commons\Travel & Expense Reports\&quot = "" Then
strSearchPath = strAccDir
Else
strSearchPath = strAccDir & "\\abc\data\abc_Commons\Travel & Expense Reports\"
End If

' Look for the main database.
If (Dir(strSearchPath & "Time & Expense Billing abc v.1.1.mdb&quot <> "&quot Then
strFileName = strSearchPath & "Time & Expense Billing abc v.1.1.mdb"
Else
' Can't find Time & Expense Billing abc v.1.1, so display the Open dialog box.
MsgBox "Relinking to the Time & Expense Billing abc v.1.1 database. " _
& "Please locate the database by browsing out to abc Commons " _
& "" _
& conAppTitle & ".", vbExclamation
strFileName = Findtest1(strSearchPath)
If strFileName = "" Then

GoTo Exit_Failed
End If
End If

' Fix the links.
If RefreshLinks(strFileName) Then
RelinkTables = True
Exit Function
End If

' If it failed, display an error.
Select Case Err
Case conNonExistentTable, conNottest1
strError = "File '" & strFileName & "' does not contain the required tables."
Case Err = conNwindNotFound
strError = "You can't run " & conAppTitle & " until you locate the database."
Case Err = conAccessDenied

 

[Remou]

Please post the Findtest1 function.

 

[simon551]

Function Findtest1(strSearchPath) As String
' Displays the Open dialog box for the user to locate
' the test1 database. Returns the full path to test1.

Dim msaof As MSA_OPENFILENAME

' Set options for the dialog box.
msaof.strDialogTitle = "Where Is the Time & Expense Billing Database?"
msaof.strInitialDir = strSearchPath
msaof.strFilter = MSA_CreateFilterString("Databases", "*.mdb&quot

' Call the Open dialog routine.
MSA_GetOpenFileName msaof

' Return the path and file name.
Findtest1 = Trim(msaof.strFullPathReturned)

End Function

 

[Remou]

You are asking for the file in both the 'main' RelinkTables module and the Findtest1 function. Alter the RelinkTables module here:

    Else
        ' Can't find Time & Expense Billing abc v.1.1, so display the Open dialog box.
       [s] MsgBox "Relinking to the Time & Expense Billing abc v.1.1 database. " _
            & "Please locate the database by browsing out to abc Commons " _
            & "" _
            & conAppTitle & ".", vbExclamation[/s]
        strFileName = Findtest1(strSearchPath)
        If strFileName = "" Then
            
            GoTo Exit_Failed
        End If

Is that what you mean?

PS You seem to have lost the Exit_Failed label.

 

[simon551]

Hi Remou,
I'm still having the same problem. This is the entire module.
The code that I run it with is:

Private Sub cmdConnect_Click()
RelinkTables

If RelinkTables = True Then
Me.txtResult.Value = "Connected"


Me.cmdFaq.SetFocus
Me.cmdConnect.Visible = False

Me.RegTimesheet.Visible = True

    Me.review.Visible = True
    Me.txtmanagecodes.Visible = True
    Me.txtcodeset.Visible = True
End If
End Sub

''''''''''''''''''''''''''''''''
'                   RefreshTableLinks                          '
'                                                              '
'      This module contains functions that refresh the         '
'      links to Time & Expense Billing ABC v.1.1 tables if they aren't available.     '
'                                                              '
''''''''''''''''''''''''''''''''
Option Explicit           ' Require variables to be declared before being used.
Option Compare Database   ' Use database order for string comparisons.

Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _
    "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Boolean
Declare Function GetSaveFileName Lib "comdlg32.dll" Alias _
    "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Boolean

Type MSA_OPENFILENAME
    ' Filter string used for the Open dialog filters.
    ' Use MSA_CreateFilterString() to create this.
    ' Default = All Files, *.*
    strFilter As String
    ' Initial Filter to display.
    ' Default = 1.
    lngFilterIndex As Long
    ' Initial directory for the dialog to open in.
    ' Default = Current working directory.
    strInitialDir As String
    ' Initial file name to populate the dialog with.
    ' Default = "".
    strInitialFile As String
    strDialogTitle As String
    ' Default extension to append to file if user didn't specify one.
    ' Default = System Values (Open File, Save File).
    strDefaultExtension As String
    ' Flags (see constant list) to be used.
    ' Default = no flags.
    lngFlags As Long
    ' Full path of file picked.  When the File Open dialog box is
    ' presented, if the user picks a nonexistent file,
    ' only the text in the "File Name" box is returned.
    strFullPathReturned As String
    ' File name of file picked.
    strFileNameReturned As String
    ' Offset in full path (strFullPathReturned) where the file name
    ' (strFileNameReturned) begins.
    intFileOffset As Integer
    ' Offset in full path (strFullPathReturned) where the file extension begins.
    intFileExtension As Integer
End Type

Const ALLFILES = "All Files"

Type OPENFILENAME
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    lpstrFilter As String
    lpstrCustomFilter As Long
    nMaxCustrFilter As Long
    nFilterIndex As Long
    lpstrFile As String
    nMaxFile As Long
    lpstrFileTitle As String
    nMaxFileTitle As Long
    lpstrInitialDir As String
    lpstrTitle As String
    Flags As Long
    nFileOffset As Integer
    nFileExtension As Integer
    lpstrDefExt As String
    lCustrData As Long
    lpfnHook As Long
    lpTemplateName As Long
End Type

Const OFN_ALLOWMULTISELECT = &H200
Const OFN_CREATEPROMPT = &H2000
Const OFN_EXPLORER = &H80000
Const OFN_FILEMUSTEXIST = &H1000
Const OFN_HIDEREADONLY = &H4
Const OFN_NOCHANGEDIR = &H8
Const OFN_NODEREFERENCELINKS = &H100000
Const OFN_NONETWORKBUTTON = &H20000
Const OFN_NOREADONLYRETURN = &H8000
Const OFN_NOVALIDATE = &H100
Const OFN_OVERWRITEPROMPT = &H2
Const OFN_PATHMUSTEXIST = &H800
Const OFN_READONLY = &H1
Const OFN_SHOWHELP = &H10

Function Findtest1(strSearchPath) As String
' Displays the Open dialog box for the user to locate
' the trst1 database. Returns the full path to test1.
    
    Dim msaof As MSA_OPENFILENAME
    
    ' Set options for the dialog box.
    msaof.strDialogTitle = "Where Is the Time & Expense Billing Database (abc commons)?"
    msaof.strInitialDir = strSearchPath
    msaof.strFilter = MSA_CreateFilterString("Databases", "*.mdb")
    
    ' Call the Open dialog routine.
    MSA_GetOpenFileName msaof
    
    ' Return the path and file name.
    Findtest1 = Trim(msaof.strFullPathReturned)
    
End Function


Function MSA_CreateFilterString(ParamArray varFilt() As Variant) As String
' Creates a filter string from the passed in arguments.
' Returns "" if no argumentss are passed in.
' Expects an even number of argumentss (filter name, extension), but
' if an odd number is passed in, it appends "*.*".
    
    Dim strFilter As String
    Dim intRet As Integer
    Dim intNum As Integer

    intNum = UBound(varFilt)
    If (intNum <> -1) Then
        For intRet = 0 To intNum
            strFilter = strFilter & varFilt(intRet) & vbNullChar
        Next
        If intNum Mod 2 = 0 Then
            strFilter = strFilter & "*.*" & vbNullChar
        End If
        
        strFilter = strFilter & vbNullChar
    Else
        strFilter = ""
    End If

    MSA_CreateFilterString = strFilter
End Function

Function MSA_ConvertFilterString(strFilterIn As String) As String
' Creates a filter string from a bar ("|") separated string.
' The string should pairs of filter|extension strings, i.e. "Access Databases|*.mdb|All Files|*.*"
' If no extensions exists for the last filter pair, *.* is added.
' This code will ignore any empty strings, i.e. "||" pairs.
' Returns "" if the strings passed in is empty.

    
    Dim strFilter As String
    Dim intNum As Integer, intPos As Integer, intLastPos As Integer

    strFilter = ""
    intNum = 0
    intPos = 1
    intLastPos = 1

    ' Add strings as long as we find bars.
    ' Ignore any empty strings (not allowed).
    Do
        intPos = InStr(intLastPos, strFilterIn, "|")
        If (intPos > intLastPos) Then
            strFilter = strFilter & Mid(strFilterIn, intLastPos, intPos - intLastPos) & vbNullChar
            intNum = intNum + 1
            intLastPos = intPos + 1
        ElseIf (intPos = intLastPos) Then
            intLastPos = intPos + 1
        End If
    Loop Until (intPos = 0)
        
    ' Get last string if it exists (assuming strFilterIn was not bar terminated).
    intPos = Len(strFilterIn)
    If (intPos >= intLastPos) Then
        strFilter = strFilter & Mid(strFilterIn, intLastPos, intPos - intLastPos + 1) & vbNullChar
        intNum = intNum + 1
    End If
    
    ' Add *.* if there's no extension for the last string.
    If intNum Mod 2 = 1 Then
        strFilter = strFilter & "*.*" & vbNullChar
    End If
    
    ' Add terminating NULL if we have any filter.
    If strFilter <> "" Then
        strFilter = strFilter & vbNullChar
    End If
    
    MSA_ConvertFilterString = strFilter
End Function

Private Function MSA_GetSaveFileName(msaof As MSA_OPENFILENAME) As Integer
' Opens the file save dialog.
    
    Dim of As OPENFILENAME
    Dim intRet As Integer

    MSAOF_to_OF msaof, of
    of.Flags = of.Flags Or OFN_HIDEREADONLY
    intRet = GetSaveFileName(of)
    If intRet Then
        OF_to_MSAOF of, msaof
    End If
    MSA_GetSaveFileName = intRet
End Function

Function MSA_SimpleGetSaveFileName() As String
' Opens the file save dialog with default values.

    Dim msaof As MSA_OPENFILENAME
    Dim intRet As Integer
    Dim strRet As String
    
    intRet = MSA_GetSaveFileName(msaof)
    If intRet Then
        strRet = msaof.strFullPathReturned
    End If
    
    MSA_SimpleGetSaveFileName = strRet
End Function

Private Function MSA_GetOpenFileName(msaof As MSA_OPENFILENAME) As Integer
' Opens the Open dialog.
    
    Dim of As OPENFILENAME
    Dim intRet As Integer

    MSAOF_to_OF msaof, of
    intRet = GetOpenFileName(of)
    If intRet Then
        OF_to_MSAOF of, msaof
    End If
    MSA_GetOpenFileName = intRet
End Function

Function MSA_SimpleGetOpenFileName() As String
' Opens the Open dialog with default values.

    Dim msaof As MSA_OPENFILENAME
    Dim intRet As Integer
    Dim strRet As String
    
    intRet = MSA_GetOpenFileName(msaof)
    If intRet Then
        strRet = msaof.strFullPathReturned
    End If
    
    MSA_SimpleGetOpenFileName = strRet
End Function

Public Function CheckLinks() As Boolean
' Check links to the test1 database; returns True if links are OK.
    
    Dim dbs As DAO.Database, rst As DAO.Recordset
    
    Set dbs = CurrentDb

    ' Open linked table to see if connection information is correct.
    On Error Resume Next
    Set rst = dbs.OpenRecordset("tblEmployees")

    ' If there's no error, return True.
    If Err = 0 Then
        CheckLinks = True
    Else
        CheckLinks = False
    End If
    
End Function

Private Sub OF_to_MSAOF(of As OPENFILENAME, msaof As MSA_OPENFILENAME)
' This sub converts from the Win32 structure to the Microsoft Access structure.
    
    msaof.strFullPathReturned = Left(of.lpstrFile, InStr(of.lpstrFile, vbNullChar) - 1)
    msaof.strFileNameReturned = of.lpstrFileTitle
    msaof.intFileOffset = of.nFileOffset
    msaof.intFileExtension = of.nFileExtension
End Sub

Private Sub MSAOF_to_OF(msaof As MSA_OPENFILENAME, of As OPENFILENAME)
' This sub converts from the Microsoft Access structure to the Win32 structure.
    
    Dim strFile As String * 512

    ' Initialize some parts of the structure.
    of.hwndOwner = Application.hWndAccessApp
    of.hInstance = 0
    of.lpstrCustomFilter = 0
    of.nMaxCustrFilter = 0
    of.lpfnHook = 0
    of.lpTemplateName = 0
    of.lCustrData = 0
    
    If msaof.strFilter = "" Then
        of.lpstrFilter = MSA_CreateFilterString(ALLFILES)
    Else
        of.lpstrFilter = msaof.strFilter
    End If
    of.nFilterIndex = msaof.lngFilterIndex
    
    of.lpstrFile = msaof.strInitialFile _
        & String(512 - Len(msaof.strInitialFile), 0)
    of.nMaxFile = 511

    of.lpstrFileTitle = String(512, 0)
    of.nMaxFileTitle = 511

    of.lpstrTitle = msaof.strDialogTitle

    of.lpstrInitialDir = msaof.strInitialDir
    
    of.lpstrDefExt = msaof.strDefaultExtension

    of.Flags = msaof.lngFlags
    
    of.lStructSize = Len(of)
End Sub

Private Function RefreshLinks(strFileName As String) As Boolean
' Refresh links to the supplied database. Return True if successful.

    Dim dbs As DAO.Database
    Dim tdf As DAO.TableDef

    ' Loop through all tables in the database.
    Set dbs = CurrentDb
    For Each tdf In dbs.TableDefs
        ' If the table has a connect string, it's a linked table.
        If Len(tdf.Connect) > 0 Then
            tdf.Connect = ";DATABASE=" & strFileName
            Err = 0
            On Error Resume Next
            tdf.RefreshLink         ' Relink the table.
            If Err <> 0 Then
                RefreshLinks = False
                Exit Function
            End If
        End If
    Next tdf

    RefreshLinks = True        ' Relinking complete.
    
End Function

Public Function RelinkTables() As Boolean
' Tries to refresh the links to the  database.
' Returns True if successful.

    Dim strAccDir As String
    Dim strSearchPath As String
    Dim strFileName As String
    Dim intError As Integer
    Dim strError As String
    
    Const conMaxTables = 8
    Const conNonExistentTable = 3011
    Const conNottest1 = 3078
    Const conNwindNotFound = 3024
    Const conAccessDenied = 3051
    Const conReadOnlyDatabase = 3027
    Const conAppTitle = "Time & Expense Billing ABC v.1.1"

    ' Get name of directory where MSAccess.exe is located.
    strAccDir = SysCmd(acSysCmdAccessDir)

    ' Get the default sample database path.
    If Dir("\\Abc\data\ABC_Commons\Travel & Expense Reports\") = "" Then
        strSearchPath = strAccDir
    Else
        strSearchPath = strAccDir & "\\Abc\data\ABC_Commons\Travel & Expense Reports\"
    End If

    ' Look for the main database.
    If (Dir(strSearchPath & "Time & Expense Billing ABC v.1.1.mdb") <> "") Then
        strFileName = strSearchPath & "Time & Expense Billing ABC v.1.1.mdb"
    Else
        ' Can't find Time & Expense Billing ABC v.1.1, so display the Open dialog box.
       ' MsgBox "Relinking to the Time & Expense Billing ABC v.1.1 database. " _
        '    & "Please locate the database by browsing out to ABC Commons " _
        '    & "" _
         '   & conAppTitle & ".", vbExclamation
        strFileName = Findtest1(strSearchPath)
        If strFileName = "" Then
            
            GoTo Exit_Failed
        End If
    End If

    ' Fix the links.
    If RefreshLinks(strFileName) Then
        RelinkTables = True
        Exit Function
    End If
    
    ' If it failed, display an error.
    Select Case Err
    Case conNonExistentTable, conNottest1
        strError = "File '" & strFileName & "' does not contain the required  tables."
    Case Err = conNwindNotFound
        strError = "You can't run " & conAppTitle & " until you locate the  database."
    Case Err = conAccessDenied
        strError = "Couldn't open " & strFileName & " because it is read-only or located on a read-only share."
    Case Err = conReadOnlyDatabase
        strError = "Can't relink tables because " & conAppTitle & " is read-only or is located on a read-only share."
    Case Else
        strError = Err.Description
    End Select
    
Exit_Failed:
    MsgBox strError, vbCritical
    RelinkTables = False
    
End Function

 

[PHV]

You're asked twice because you do the job twice !
Private Sub cmdConnect_Click()
RelinkTables

If RelinkTables = True Then
Me.txtResult.Value = "Connected"
...


Hope This Helps, PH.
Want to get great answers to your Tek-Tips questions? Have a look at FAQ219-2884 or FAQ181-2886