Re: Changing the background color and re-linking the backend when

Hi All,
Here is the code that I used. It is based on Klatuu's code and I just adjusted it for my needs and added a message at the end.
I figured I'll upload it for anybody else that might have a situation like mine.
The only problem i have with it is that I get to message boxes popping up for every table that it cannot resolve the link for.
I have a similar function that uses different backends, depending on the last two letters of the table.
In order to do that I had to rename some tables. Of course I had to re-do alot of queries and reports for everything to work.
I used Notepad+ that allows you to do a multi replace in all open documents.
I opened all the queries and copied every SQL statement into a separate document and did a multi-replace in all open documents.
I wonder if there is an easier way, script that does the same thing. Essentially what I needed was to replace every reference to tblMember to be replaced to tblMemberUS in one Access database and to tblMemberNU in another Access database.
Later on I incorporated all the stuff into one consolidated DB.

Thanks alot,
Shimon


Private Sub Form_Open(Cancel As Integer)
' Code used in startup form to change color and refresh links
Dim strDisk As String
Dim strDbName As String
strDisk = Left$(CurrentDb.Name, 1)

If strDisk = "X" Then Me.Detail.BackColor = 12632256
If strDisk <> "X" Then
If strDisk <> "C" Then
Me.Detail.BackColor = 16751052 ' purple
Else
Me.Detail.BackColor = 8388608 'green
End If
End If

If CheckLink = False Then RefreshLinksBeSef

End Sub


Function CheckLink() As Boolean
' This Procedure needs a reference to Microsoft DOA (3.6) Object Library CheckLink = False
Dim Db As Database
Dim tdf As TableDef
Set Db = CurrentDb

For Each tdf In Db.TableDefs
' Uses specific table name that should always be a linked table
If Left(tdf.Name, 9) = "tblMember" And Len(tdf.Name) < 12 Then
If Mid(tdf.Connect, 11, 1) = Left(Db.Name, 1) Then CheckLink = True
'Connect property is = Current Drive
End If
Next tdf

Set dbs = Nothing
Set tdf = Nothing

End Function





Function RefreshLinksBeSef() As Boolean
' This Procedure needs a reference to Microsoft DOA (3.6) Object Library
' refreshes all Backend tables to the current disk of this application.
'Const constServerShareName = "\\Server2\Data\"
'Const BackendPathAuctions = "Auctions\_AccessDB\BE_Auctions.mdb"
'Const DBPathAuctioNS = "seforim\FUNDSYST\"
RefreshLinksBeSef = False
Dim Db As Database
Dim tdf As TableDef
Dim strDisk As String
Dim RelinkAtEnd As Boolean
Set Db = CurrentDb
DoCmd.Hourglass True
On Error GoTo ErrLinkUpExit

If Left$(CurrentDb.Name, 1) = "\" Then ' DB path is a UNC
strDisk = constServerShareName
Else ' DB path is a Disk letter
strDisk = Left$(CurrentDb.Name, 3)
End If

For Each tdf In Db.TableDefs
If tdf.Connect <> "" Then 'table is a linked table
If Left(tdf.Connect, 5) = "dBase" Then
tdf.Connect = "dBase 5.0;HDR=NO;IMEX=2;DATABASE=" & strDisk & DBPathAuctioNS
tdf.RefreshLink
RefreshLinksBeSef = True

Else
tdf.Connect = ";DATABASE=" & strDisk & BackendPathAuctions
tdf.RefreshLink
RefreshLinksBeSef = True
End If
End If
Next tdf

Set dbs = Nothing
Set tdf = Nothing

If RelinkAtEnd = True Then LinkTables



DoCmd.Hourglass False


RefreshLinksNotice


Exit Function
DoCmd.Hourglass True
On Error GoTo ErrLinkUpExit
ErrLinkUpExit:
DoCmd.Hourglass False

Select Case Err
Case 3031 ' Password Protected
MsgBox ("Back End for '" & tdf.Name & " is password protected")
Case 3011 ' Table missing
DoCmd.Hourglass False
MsgBox ("Back End does not contain required table for '" & tdf.Name & "'")
Case 3024 ' Back End not found
MsgBox ("Back End Database for '" & tdf.Name & "'" & " Not Found")
Case 3051 ' Access Denied
MsgBox ("Access to Backend for '" & tdf.Name & "' Denied" & vbCrLf & _
"May be Network Security or Read Only Database")
Case 3027 ' Read Only
MsgBox ("Back End for'" & tdf.Name & "'" & " is Read Only ")
Case 3044 ' Invalid Path
MsgBox ("Path for '" & tdf.Name & " Is Not a Valid Path")
MsgBox ("No Valid Path for " & tdf.Name)
Case 3265
MsgBox ("Table for '" & tdf.Name & "'" & _
" Not Found in Backend ")
Case 3321 ' Nothing Entered
DisplayMsg ("No Database Name Entered")
Case Else
GoTo MyErrorRoutine:
' Me.lblMsg.Caption = "Uncaptured Error " & str(Err) & Err.Description
MsgBox ("Uncaptured Error " & str(Err) & Err.Description)
End Select

Resume Next

Exit Function
On Error GoTo MyErrorRoutine
MyErrorRoutine:
ErrorNotice
Resume Next

End Function




Public Sub RefreshLinksNotice()
MsgBox ("All links were refreshed, unless you recieved an error message for specific tables")
End Sub








Shimon wrote:
I didn't like this code either. I used Klatuu's code and it ended up working fine. I added a loop to check where the DB is located and added a loop to take care of UNC's.
Maybe I'll upload the final code sometime.
Thanks alot,
Shimon

Klatuu wrote:
There reason you are getting 15 tables when you have only 8 is that the system tables which are hidden are included in the count. You don't want to use any table that starts with msys.

Here is a routine that will relink to a database you have selected. I did not write it, and there are things about it I don't like, but it does work. You will also need to copy the code at this site:

http://www.mvps.org/access/api/api0001.htm

It is used in this code.

Option Compare Database
Option Explicit

Dim UnProcessed As New Collection
Private Declare Function GetOpenFileName _
Lib "comdlg32.dll" Alias "GetOpenFileNameA" _
(pOpenfilename As OPENFILENAME) As Long

Private Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter 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
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type

Public Function BrowseNF()
Dim OFN As OPENFILENAME
Dim Ret
Dim GetFileFromAPI As String

With OFN
.lStructSize = Len(OFN)
.nMaxFile = 260 'The size given for the filepath and name i.e. c:\prnin\outfile.txt at least 256
.lpstrTitle = "Please Select New Data File" 'Title of the Dialog Box
.lpstrInitialDir = "O:\Contract" 'Default Directory for the Dialog box This can also be "\\server\dir"
'Filter the types of files for the Dialog box.
.lpstrFilter = "Access Database(*.mdb;*.mda;*.mde;*.mdw)|" & "*.mdb; *.mda; *.mde; *.mdw|All(*.*)|*.*"
.lpstrFile = String(.nMaxFile - 1, 0) 'get the buffer ready
Ret = GetOpenFileName(OFN) ' Call function.
GetFileFromAPI = Trim(Replace(.lpstrFile, vbNullChar, " "))
If Len(.lpstrFile) > 0 Then ' user responded, put selection into text box on form.
[Forms]![frmNewDatafile]![txtFileName] = .lpstrFile
End If
End With
Exit_BrowseNF:
Exit Function

Err_BrowseNF:
MsgBox Err.Description
Resume Exit_BrowseNF

End Function

Public Sub AppendTables()

Dim db As DAO.Database, x As Variant
' Add names of all table with invalid links to the Unprocessed Collection.
Set db = CurrentDb
ClearAll
For Each x In db.TableDefs
If Len(x.Connect) > 1 Then
' connect string exists, but file does not
UnProcessed.Add Item:=x.Name, Key:=x.Name
End If
Next

End Sub

Public Function ProcessTables()

Dim strTest As String
On Error GoTo Err_BeginLink
' Call procedure to add all tables with broken links into a collection.
AppendTables
' Test for existence of file name\directory selected in Common Dialog Control.
strTest = Dir([Forms]![frmNewDatafile]![txtFileName])
On Error GoTo Err_BeginLink
If Len(strTest) = 0 Then ' File not found.
MsgBox "File not found. Please try again.", vbExclamation, "Link to new data file"
Exit Function
End If
' Begin relinking tables.
Relinktables (strTest)
' Check to see if all tables have been relinked.
CheckifComplete
DoCmd.Echo True, "Done"
If UnProcessed.Count < 1 Then
MsgBox "Linking to new back-end data file was successful."
Else
MsgBox "Not All back-end tables were successfully relinked."
End If

'Here is where you need to modify code to fit into your app.

' DoCmd.Close acForm, [Forms]![frmNewDatafile].Name
' DoCmd.OpenForm "Switchboard"
Exit_BeginLink:
DoCmd.Echo True
Exit Function
Err_BeginLink:
Debug.Print Err.Number
If Err.Number = 457 Then
ClearAll
Resume Next
End If
MsgBox Err.Number & ": " & Err.Description
Resume Exit_BeginLink

End Function

Public Sub ClearAll()
Dim x
' Clear any and all names from the Unprocessed Collection.
For Each x In UnProcessed
UnProcessed.Remove (x)
Next
End Sub

Public Function Relinktables(strFileName As String)

Dim dbbackend As DAO.Database, dblocal As DAO.Database, x, y
Dim tdlocal As DAO.TableDef
On Error GoTo Err_Relink

'You can modify this line if you don't have a database password
Set dbbackend = DBEngine(0).OpenDatabase(strFileName, False, False, "MS Access;PWD=xxxx")
Set dblocal = CurrentDb
' If the local linked table name is found in the back-end database
' we're looking at, Recreate & Refresh its connect string, and then
' remove its name from the Unprocessed collection.
For Each x In UnProcessed
If Len(dblocal.TableDefs(x).Connect) > 0 Then
For Each y In dbbackend.TableDefs
If y.Name = x Then
Set tdlocal = dblocal.TableDefs(x)
tdlocal.Connect = ";DATABASE=" & _
Trim([Forms]![frmNewDatafile]![txtFileName])
tdlocal.RefreshLink
UnProcessed.Remove (x)
End If
Next
End If
Next

Exit_Relink:
Exit Function

Err_Relink:
MsgBox Err.Number & ": " & Err.Description
Resume Exit_Relink

End Function

Public Sub CheckifComplete()

Dim strTest As String, y As String, notfound As String, x
On Error GoTo Err_BeginLink
' If there are any names left in the unprocessed collection,
' then continue.
If UnProcessed.Count > 0 Then
For Each x In UnProcessed
notfound = notfound & x & Chr(13)
Next
' List the tables that have not yet been relinked.
y = MsgBox("The following tables were not found in " & _
Chr(13) & Chr(13) & [Forms]![frmNewDatafile]!txtFileName _
& ":" & Chr(13) & Chr(13) & notfound & Chr(13) & _
"Select another database that contains the additional tables?", _
vbQuestion + vbYesNo, "Tables not found")
If y = vbNo Then
Exit Sub
End If
' Bring the Open File Dialog back up.
Browse
strTest = Dir([Forms]![frmNewDatafile]![txtFileName])
If Len(strTest) = 0 Then ' File not found.
MsgBox "File not found. Please try again.", vbExclamation, _
"Link to new data file"
Exit Sub
End If
Debug.Print "Break"
Relinktables (strTest)
Else
Exit Sub
End If
CheckifComplete
Exit_BeginLink:
DoCmd.Echo True ' Just in case of error jump.
DoCmd.Hourglass False
Exit Sub

Err_BeginLink:
Debug.Print Err.Number
If Err.Number = 457 Then
ClearAll
Resume Next
End If
MsgBox Err.Number & ": " & Err.Description
Resume Exit_BeginLink

End Sub


.

Relevant Pages

  • RE: Combo Box on User Form
    ... 'declare variables for new connection and recordset and declare variables ... Dim vConnection As New ADODB.Connection ... Dim vClientFName As String ... MsgBox "The connection to this database is working!", ...
    (microsoft.public.word.vba.general)
  • Re: running fRefreshLinks from another database
    ... lock the database I want to update links in. ... Dim i As Integer, strDBPath As String, strTbl As String ... Dim dbCurr As Database, dbLink As Database ...
    (microsoft.public.access.modulesdaovba)
  • Re: Combo Box on User Form
    ... 'declare variables for new connection and recordset and declare variables ... Dim vConnection As New ADODB.Connection ... Dim vClientFName As String ... MsgBox "The connection to this database is working!", ...
    (microsoft.public.word.vba.general)
  • Re: A VB 6 program to read from and save to text file
    ... I wrote a small program which for you, which imports the data from your text file into a database and displays them in a DBGrid. ... Const OldFile As String = "Datafile.txt.old" ... Dim MyData As String ... Kill MyPath & OldFile ...
    (microsoft.public.vb.winapi)
  • Search pattern
    ... Dim strfile As String ... Dim bAddressFound As Boolean ... Dim strCurrentChar As String ...
    (comp.databases.ms-access)