Help with this VB code to relink Access Table

I have a Retail program that has very limited reporting options, however it does let me save reports as .txt (Tab Delimited file).

With the retail program I use I export several different reports to Tab Delimited  .txt files. - All the .txt files have the same number of fields and Field Names.

I have created an Access Database that gives me all the reports I need.
In Access I have Imported the tab delimited file to a Linked Table in my Access program. All my Queries and Reports are based off this Linked Table. In Access I can very easlily use the Linked Table Manager to select a different .txt (Tab Delimited) file and Access will automatically re-link to the new tab delimited file with no problem. I then run my reports to view this new information.

What I need to do is steamline this process by using a button on a form so I can easly re-link to whatever Tab Delimited file I need to view reports.

I found the function below "Relink Access tables from code" which is perfect except that it will not relink a Tab Delimited file. Only a .mdb file. It gets an error of Unrecognized Data Format when trying to relink a Tab Delimited File or any file that is not a .mdb file.

Can anyone help on modifying this code to work with a Tab Delimited file?

Thanks in Advance!

Function: "Relink Access tables from code"

' Code Courtesy of
' Dev Ashish
'
Function fRefreshLinks() As Boolean
Dim strMsg As String, collTbls As Collection
Dim i As Integer, strDBPath As String, strTbl As String
Dim dbCurr As DATABASE, dbLink As DATABASE
Dim tdfLocal As TableDef
Dim varRet As Variant
Dim strNewPath As String

Const cERR_USERCANCEL = vbObjectError + 1000
Const cERR_NOREMOTETABLE = vbObjectError + 2000

    On Local Error GoTo fRefreshLinks_Err

    If MsgBox("Are you sure you want to reconnect all Access tables?", _
            vbQuestion + vbYesNo, "Please confirm...") = vbNo Then Err.Raise cERR_USERCANCEL

    'First get all linked tables in a collection
    Set collTbls = fGetLinkedTables

    'now link all of them
    Set dbCurr = CurrentDb

    strMsg = "Do you wish to specify a different path for the Access Tables?"
   
    If MsgBox(strMsg, vbQuestion + vbYesNo, "Alternate data source...") = vbYes Then
        strNewPath = fGetMDBName("Please select a new datasource")
    Else
        strNewPath = vbNullString
    End If

    For i = collTbls.Count To 1 Step -1
        strDBPath = fParsePath(collTbls(i))
        strTbl = fParseTable(collTbls(i))
        varRet = SysCmd(acSysCmdSetStatus, "Now linking '" & strTbl & "'....")
        If Left$(strDBPath, 4) = "ODBC" Then
            'ODBC Tables
            'ODBC Tables handled separately
           ' Set tdfLocal = dbCurr.TableDefs(strTbl)
           ' With tdfLocal
           '     .Connect = pcCONNECT
           '     .RefreshLink
           '     collTbls.Remove (strTbl)
           ' End With
        Else
            If strNewPath <> vbNullString Then
                'Try this first
                strDBPath = strNewPath
            Else
                If Len(Dir(strDBPath)) = 0 Then
                    'File Doesn't Exist, call GetOpenFileName
                    strDBPath = fGetMDBName("'" & strDBPath & "' not found.")
                    If strDBPath = vbNullString Then
                        'user pressed cancel
                        Err.Raise cERR_USERCANCEL
                    End If
                End If
            End If

            'backend database exists
            'putting it here since we could have
            'tables from multiple sources
            Set dbLink = DBEngine(0).OpenDatabase(strDBPath)

            'check to see if the table is present in dbLink
            strTbl = fParseTable(collTbls(i))
            If fIsRemoteTable(dbLink, strTbl) Then
                'everything's ok, reconnect
                Set tdfLocal = dbCurr.TableDefs(strTbl)
                With tdfLocal
                    .Connect = ";Database=" & strDBPath
                    .RefreshLink
                    collTbls.Remove (.Name)
                End With
            Else
                Err.Raise cERR_NOREMOTETABLE
            End If
        End If
    Next
    fRefreshLinks = True
    varRet = SysCmd(acSysCmdClearStatus)
    MsgBox "All Access tables were successfully reconnected.", _
            vbInformation + vbOKOnly, _
            "Success"

fRefreshLinks_End:
    Set collTbls = Nothing
    Set tdfLocal = Nothing
    Set dbLink = Nothing
    Set dbCurr = Nothing
    Exit Function
fRefreshLinks_Err:
    fRefreshLinks = False
    Select Case Err
        Case 3059:

        Case cERR_USERCANCEL:
            MsgBox "No Database was specified, couldn't link tables.", _
                    vbCritical + vbOKOnly, _
                    "Error in refreshing links."
            Resume fRefreshLinks_End
        Case cERR_NOREMOTETABLE:
            MsgBox "Table '" & strTbl & "' was not found in the database" & _
                    vbCrLf & dbLink.Name & ". Couldn't refresh links", _
                    vbCritical + vbOKOnly, _
                    "Error in refreshing links."
            Resume fRefreshLinks_End
        Case Else:
            strMsg = "Error Information..." & vbCrLf & vbCrLf
            strMsg = strMsg & "Function: fRefreshLinks" & vbCrLf
            strMsg = strMsg & "Description: " & Err.Description & vbCrLf
            strMsg = strMsg & "Error #: " & Format$(Err.Number) & vbCrLf
            MsgBox strMsg, vbOKOnly + vbCritical, "Error"
            Resume fRefreshLinks_End
    End Select
End Function

Function fIsRemoteTable(dbRemote As DATABASE, strTbl As String) As Boolean
Dim tdf As TableDef
    On Error Resume Next
    Set tdf = dbRemote.TableDefs(strTbl)
    fIsRemoteTable = (Err = 0)
    Set tdf = Nothing
End Function

Function fGetMDBName(strIn As String) As String
'Calls GetOpenFileName dialog
Dim strFilter As String

    strFilter = ahtAddFilterItem(strFilter, _
                    "Access Database(*.mdb;*.mda;*.mde;*.mdw) ", _
                    "*.mdb; *.mda; *.mde; *.mdw")
    strFilter = ahtAddFilterItem(strFilter, _
                    "All Files (*.*)", _
                    "*.*")

    fGetMDBName = ahtCommonFileOpenSave(Filter:=strFilter, _
                                OpenFile:=True, _
                                DialogTitle:=strIn, _
                                Flags:=ahtOFN_HIDEREADONLY)
End Function

Function fGetLinkedTables() As Collection
'Returns all linked tables
    Dim collTables As New Collection
    Dim tdf As TableDef, db As DATABASE
    Set db = CurrentDb
    db.TableDefs.Refresh
    For Each tdf In db.TableDefs
        With tdf
            If Len(.Connect) > 0 Then
                If Left$(.Connect, 4) = "ODBC" Then
                '    collTables.Add Item:=.Name & ";" & .Connect, KEY:=.Name
                'ODBC Reconnect handled separately
                Else
                    collTables.Add Item:=.Name & .Connect, Key:=.Name
                End If
            End If
        End With
    Next
    Set fGetLinkedTables = collTables
    Set collTables = Nothing
    Set tdf = Nothing
    Set db = Nothing
End Function

Function fParsePath(strIn As String) As String
    If Left$(strIn, 4) <> "ODBC" Then
        fParsePath = Right(strIn, Len(strIn) _
                        - (InStr(1, strIn, "DATABASE=") + 8))
    Else
        fParsePath = strIn
    End If
End Function

Function fParseTable(strIn As String) As String
    fParseTable = Left$(strIn, InStr(1, strIn, ";") - 1)
End Function
'***************** Code End ***************
LVL 2
ACSPanamaAsked:
Who is Participating?
 
harfangCommented:
ACSPanama

Let's solve this the simple way. Follow these steps:

0) Naturally, back-up your database...

1) Make sure you have a link specification for your tab file.

If not, delete your table link and relink ("file / get external data / link tables..."). In the wizard, follow the normal steps, but click on the button "Advanced" to check, adjust and save the current file specification, under any name. Write that name down.

2) Create a new blank form, with these two controls:

    a) a blank list box, with these properties:
        Name: lstFiles
        Row Source Type: Value List

    b) a command button named: cmdRelink

3) Open the form's module (menu "view / code") and paste the module below into it.

4) Adjust the three constants at the top

WARNING: The linked table in TEXT_TABLE will be deleted and overwritten each time. If you enter the name of an actual table, that table will be deleted!

5) Compile, save, and test...

----------------------------------------------------------------------------------------->8----
Option Compare Database
Option Explicit

' useful constants
Const TEXT_TABLE = "Name of the linked table"
Const TEXT_SPECS = "Name of the import specifications"
Const TEXT_PATH = "Full path, with trailing \"

Private Sub Form_Load()
'
' fills the list box lstFiles with all found files in the folder
'
    Dim strFileName As String
    Dim strPath As String
   
    ' get first file using path and wildcard
    strFileName = Dir(TEXT_PATH & "*.txt")
    Do Until strFileName = ""
        ' fill listbox "value list" with file names
        Me.lstFiles.RowSource = Me.lstFiles.RowSource _
            & strFileName & ";"
        ' get next file
        strFileName = Dir()
    Loop
   
End Sub

Private Sub cmdRelink_Click()
'
' Deletes the linked table and relinks
'
On Error GoTo Problem
    ' user selected one?
    If IsNull(lstFiles) Then lstFiles.SetFocus: Exit Sub
   
    ' remove old table link, relink and open
    DoCmd.DeleteObject acTable, TEXT_TABLE
    DoCmd.TransferText acLinkDelim, TEXT_SPECS, TEXT_TABLE, lstFiles, False
    DoCmd.OpenTable TEXT_TABLE
    Exit Sub
   
Problem:
    ' if the table does not exist, just recreate it
    If Err.Number = 7874 Then Resume Next
    ' else inform user
    MsgBox Err.Description, Title:="Error " & Err.Number
    Err.Clear
End Sub
----------------------------------------------------------------------------------------->8----

This should give you the needed funtionality.

Good luck, tell me how it goes!
(°v°)
0
 
harfangCommented:
Hello ACSPanama

The central piece of your code is:

                With tdfLocal
                    .Connect = ";Database=" & strDBPath
                    .RefreshLink
                End With

That works with Jet databases. For text files, the connect string is slightly more complicated, e.g.:

    Text;DSN=«spec»;
    FMT=Delimited;
    HDR=NO;
    IMEX=2;
    CharacterSet=1252;
    DATABASE=«path»

(all in one line, though), and the actual file name is stored in .SourceTableName... This means that the process is quite different whether you want to change the path or the file name!

To get you started, here are two functions that change path or the file name of the linked table in the constant TEXT_TABLE:


Const TEXT_TABLE = "Name of the linked table"

Sub TextLinkNewPath(pstrPath As String)
'
' change connect string and relink!
'
    With CurrentDb
        With .TableDefs(TEXT_TABLE)
            .Connect = Left(.Connect, InStr(.Connect, "DATABASE=") + 8) & pstrPath
            .RefreshLink
        End With
    End With
End Sub

Sub TextLinkNewFile(pstrFile As String)
'
' create a new tabledef, replacing the old one
'
    Dim tdfNew As TableDef
   
    With CurrentDb
        Set tdfNew = .CreateTableDef()
        With .TableDefs(TEXT_TABLE)
            tdfNew.Name = .Name
            tdfNew.Connect = .Connect
            tdfNew.SourceTableName = pstrFile
        End With
        .TableDefs.Delete tdfNew.Name
        .TableDefs.Append tdfNew
    End With
End Sub


Happy programming!

(°v°)
0
 
ACSPanamaAuthor Commented:
harfang - I also found this function  http://www.mvps.org/access/tables/tbl0012.htm

however it was writen for Access 95 and I get errors when I try to use in in Access 2002/XP
pershaps you could help me get this code to work in Access 2002/XP or take some of this function to get the previouse funtion to work with Tab Delimited files:

Function: Relink tables from different datasources

' Code Courtesy of
' Timothy Pascoe and Lyle Fairfield
'
Const IntAttachedTableType As Integer = 6
Const ALLFILES = "All Files"

Function fGetMDBName(strIn As String) As String
'Calls GetOpenFileName dialog
Dim strFilter As String

    strFilter = ahtAddFilterItem(strFilter, _
                    "Access Database(*.mdb;*.mda;*.mde;*.mdw) ", _
                    "*.mdb; *.mda; *.mde; *.mdw")
    strFilter = ahtAddFilterItem(strFilter, _
                    "All Files (*.*)", _
                    "*.*")

    fGetMDBName = ahtCommonFileOpenSave(Filter:=strFilter, _
                                OpenFile:=True, _
                                DialogTitle:=strIn, _
                                Flags:=ahtOFN_HIDEREADONLY)
End Function
Function fRefreshLinks() As Boolean
' Code courtesy of:
' Microsoft Access 95 Solutions database
' Modified for Multiple Back-ends by Lyle Fairfield
' Updated to handle cancelation/incorrect selection by Timothy J. Pascoe
' Except where otherwise noted.

    Dim dbs As Database
    Dim rst As Recordset, rstTry As Recordset
    Dim tdf As TableDef
    Dim strOldConnect As String, strNewConnect As String
    Dim strFullLocation As String, strDatabase As String, strMsg As String

    Set dbs = CurrentDb()
    Set rst = dbs.OpenRecordset("SELECT MSysObjects.Connect, MsysObjects.Database, " & _
                             "MSysObjects.Name from MSysObjects " & _
                             "WHERE MSysObjects.Type = " & IntAttachedTableType)
    If rst.RecordCount <> 0 Then
        rst.MoveFirst
        Do
            On Error Resume Next
            Set rstTry = dbs.OpenRecordset(rst![Name].Value)
                If Err = 0 Then
                    rstTry.Close
                    Set rstTry = Nothing
                Else
                    On Error GoTo fRefreshLinks_Err
                    strFullLocation = rst.Name
                    strDatabase = FileName(strFullLocation)
                    Set tdf = dbs.TableDefs(rst![Name].Value)
                    strOldConnect = tdf.Connect
                    strNewConnect = findConnect(strDatabase, tdf.Name, strOldConnect)
                    'If strNewConnect = "" Then
                        'Err.Raise
                    'Else
                        For Each tdf In dbs.TableDefs
                            If tdf.Connect = strOldConnect Then
                                tdf.Connect = strNewConnect
                                tdf.RefreshLink
                            End If
                        Next tdf
                        dbs.TableDefs.Refresh
                    'End If
                End If
                Err = 0
            rst.MoveNext
            If rst.EOF Then
                Exit Do
            End If
        Loop
    End If

fRefreshLinks_End:
    Set tdf = Nothing
    Set rst = Nothing
    Set rstTry = Nothing
    fRefreshLinks = True
    Exit Function

fRefreshLinks_Err:
    fRefreshLinks = False
    Select Case Err
        Case 3024:

        Case Else:
            strMsg = "Error Information..." & vbCrLf & vbCrLf
            strMsg = strMsg & "Function: fRefreshLinks" & vbCrLf
            strMsg = strMsg & "Description: " & Err.Description & vbCrLf
            strMsg = strMsg & "Error #: " & Format$(Err.Number) & vbCrLf
            MsgBox strMsg, vbOKOnly + vbCritical, "Error"
    End Select
    Exit Function
End Function

Function findConnect(strDatabase As String, strFileName As String, strConnect As String) As Variant
    Dim strSearchPath As String, strFileType As String, strFileSkelton As String
    Dim aExtension(6, 1) As String, i As Integer, _
    strFindFullPath As String, strFindPath As String, strParameters As String
    strSearchPath = directoryFromConnect(strConnect)
    strFileType = "All Files"
    strFileSkelton = "*.*"
    aExtension(0, 0) = "dBase"
    aExtension(0, 1) = ".dbf"
    aExtension(1, 0) = "Paradox"
    aExtension(1, 1) = ".db"
    aExtension(2, 0) = "FoxPro"
    aExtension(2, 1) = ".dbf"
    aExtension(3, 0) = "Excel"
    aExtension(3, 1) = ".xls"
    aExtension(4, 0) = "Text"
    aExtension(4, 1) = ".txt"
    aExtension(5, 0) = "Exchange"
    aExtension(5, 1) = ".*"
    aExtension(6, 0) = "Access"
    aExtension(6, 1) = ".mdb"
    For i = 0 To 6
        If InStr(strConnect, aExtension(i, 0)) <> 0 Then
            strFileName = strFileName & aExtension(i, 1)
            strFileSkelton = "*" & aExtension(i, 1)
            strFileType = aExtension(i, 0)
            Exit For
        End If
    Next i

    strFindFullPath = findFile(strDatabase, strSearchPath, strFileType, strFileSkelton)
    If strFindFullPath <> "" Then
        strFindPath = strPathfromFileName(strFindFullPath)
        strParameters = parametersFromConnect(strConnect)
        If InStr(strFindFullPath, "dbf") <> 0 Then
            findConnect = strParameters & strFindPath
        Else
            findConnect = strParameters & strFindFullPath
        End If
    End If
End Function
Function directoryFromConnect(strConnect As String) As String
    directoryFromConnect = Mid(strConnect, InStr(strConnect, "DATABASE=") + 9)
End Function
Function parametersFromConnect(strConnect As String) As String
    parametersFromConnect = left(strConnect, InStr(strConnect, "DATABASE=") + 8)
End Function
Function strPathfromFileName(strFileName As String) As String
    Dim i As Integer
    For i = Len(strFileName) To 1 Step -1
        If Mid(strFileName, i, 1) = "\" Then
            Exit For
        End If
    Next i
    strPathfromFileName = left(strFileName, i - 1)
End Function
Function findFile(strDatabase, strSearchPath, strFileType, strFileSkelton) As String

    Dim strSelectedDatabase As String, strFullLocation As String, intlen As Integer, i As Integer
    Dim strIn As String
   
    Do
        strIn = "Where Is " & strDatabase & "?"
        findFile = Trim(fGetMDBName(strIn))
        strSelectedDatabase = FileName(findFile)
        If strSelectedDatabase = "" Then
            Exit Do
        ElseIf strDatabase <> strSelectedDatabase Then
            MsgBox "You selected " & strSelectedDatabase & _
                 "@This is not the correct database.@Please select " & _
                 strDatabase & ".", vbInformation + vbOKOnly
        End If
    Loop Until strSelectedDatabase = strDatabase

End Function

Public Function FileName(strFullLocation As String)

    Dim intlen As Integer, i As Integer

    'Get the Database Name, for use on the 'Find File' Form Caption
    intlen = Len(strFullLocation)
    For i = intlen To 1 Step -1
        If Mid$(strFullLocation, i, 1) = "\" Then
            FileName = right$(strFullLocation, intlen - i)
            Exit For
        End If
    Next i

End Function
'*********** Code End ************
0
Free Tool: IP Lookup

Get more info about an IP address or domain name, such as organization, abuse contacts and geolocation.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

 
harfangCommented:
Hello ACSPanama

The link was enough. No need to copy-paste long modules here, thank you.
Incidentally, this does not work for text files. As explained, changing the file name requires a new tabledef object.

Have you tried my functions?

(°v°)
0
 
ACSPanamaAuthor Commented:
Harfang - First off thanks for helping
The original function http://www.mvps.org/access/tables/tbl0009.htm already prompts me for a new data path and file name. It just wil not recognize file formats other than .mdb

If I change the central piece of code From:

With tdfLocal
   .Connect = ";Database=" & strDBPath
   .RefreshLink
End With

to:

With tdfLocal
   .Connect = DSN = " & strTbl; FMT=Delimited; HDR=NO; IMEX=2; CharacterSet=1252; Database=" & strDBPath
   .RefreshLink
End With

Still doesn't work. Can you rewrite the .connect line for me so it will work?

Thanks

0
 
harfangCommented:
ACSPanama

I don't think I can make this line work. The problem is that if you change the *file* *name* the method in your lengthy code samples does not work. You cannot just rewrite the connect string and relink. You still did not try the functions, did you?

Sorry for asking, but are you confident enough in VB to tackle this? I will not develop the module for you, nor will I modify the code samples you found. That is your job. I might expand a little on the functions I provided if you wish.

For example, extract from the samples the portion where the user can select a file. Then examine if it's the same folder with a new file name or the same file name in another folder. Depending on that, choose one of the functions I provided to relink the table. Can you do that?

If not, you should break this down into smaller manageable portions:

1) Get the user to browse for a file name. Extract that from the samples or find other samples until you have a simple function you totally understand that  simply provides a path and file name selected by the user. Nothing else, just the message "you selected C:\tmp\toto.txt".

2) Examine the tabledef object. Try the functions I provided until you can at will and through code relink your table to any new path or file name that you hard-code or enter from the immediate pane. Again, just that... simple: TextLinkNewFile "test file.txt"

3) Bring this together, providing enough error management to make sure you do not loose the original tabledef object or the import specifications.

Please start writing your own functions. You cannot just cut-and-paste code samples if you do not understand every single line...

Good luck
(°v°)
0
 
ACSPanamaAuthor Commented:
I'm not trying to just cut-and-paste code samples. What I was doing is trying to analyze these code samples to help resolve my problem.

In a nut shell I need to be able to re-link to a file by code.  This Function works great if the file that I am linking to is a .mob file (even if the new file has a different name or path): http://www.mvps.org/access/tables/tbl0009.htm   the only thing is that it won't work with delimited files. I was hoping that there could be a change that would not be to difficult so that the function would accept a Tab Delimited file, however if it is to difficult for you or to lengthy a process for you, then I understand. Obviously I wouldn't of posted the question if I didn't need the help, or as you put it "not confident enough in VB to tackle this".
0
 
ACSPanamaAuthor Commented:
Does Exactly what I needed...well done...and thank you.  Had to fix the

DoCmd.TransferText acLinkDelim, TEXT_SPECS, TEXT_TABLE, lstFiles, False
to
DoCmd.TransferText acLinkDelim, TEXT_SPECS, TEXT_TABLE, TEXT_PATH + lstFiles, False

because the TEST_PATH was missing and I was getting a file not found error, but other than that it works great and was well thought out...(I liked the listbox idea with the file names) makes it very user friendly and convienient.
0
 
harfangCommented:
Glad you liked it. Sorry about the missing path, I guess it was my default path when testing, so that everything appeared to work fine ;)

Note that you can easily change the linking to importing (use the constant acImportDelim instead). You could create a more detailed import specification file, providing also the needed indexes and possibly a primary key, but even without it, any reports or statistics based on the table would run much faster.

The downside is that your database would grow very quickly (you would need "tools / options", [General], "Compact on Close", most likely), but then again, linked text tables are really slow...

Good luck with your project!
(°v°)
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.