Re: Re-Linking Tables, based on INI file

J-P-W <jonpwebb@xxxxxxxxx> wrote in
news:5081fef3-b9c6-4b9a-a170-f444ee0b222f@xxxxxxxxxxxxxxxxxxxxxxxxxxxx:

Hi,

I've successfully used code from

http://www.utteraccess.com/forums/printthread.php?Cat=&Board=3&main=156
9734&type=thread

To re-link tables based on their file location recorded in an INI
file.

However, I now need to adjust the code so that the INI file could have
multiple locations e.g.:

BEPath1=\\MyUNCPath\
BEDB1=MyBackend1.mdb
BEPath2=\\MyUNCPath\
BEDB2=MyBackend2.mdb

Using:
Function RefreshBE_Tables()
RefreshLinks (GetString("BEPath1") & GetString("BEDB1"))
RefreshLinks (GetString("BEPath2") & GetString("BEDB2"))
End Function

But I can only get it to read the first entry, and having correctly
re- linked that it doesn't go on to the second file location.

I was hoping to use this and then if it fails to use the code from
http://www.mvps.org/access/tables/tbl0009.htm to ask for the missing
location.

Has anyone already written such code? Or point to how to modify this
to get it to work?

Many thanks

Jon

A century ago I wrote code (as a form module) that examined tabledefs,
and created a collection of unique backends and relinked each.
So if a frontend was linked to two backends and the links were broken
then user was prompted to provide two new links. Code is below. It's
wonderfully archaic and I would not do it that way today; I would almost
certainly use some sort of recursion.

You may find something of use in it. It is not "just plug it in and use
it code". I'm not a supporter of users running around using tools of
which they know zip.

If anyone believes it borrows from someone else's code I may say that
there are origins and then there are the origins of origins.

Option Compare Database
Option Explicit

Private Declare Function CommDlgExtendedError Lib "comdlg32.dll" () As
Long

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

Private Const OFN_HIDEREADONLY = &H4
Private Const OFN_NOCHANGEDIR = &H8
Private Const OFN_SHAREAWARE = &H4000
Private Const MAX_PATH = 260
Private Const DELIMITER = vbNewLine & "GO" & vbNewLine
Dim colDistinctLinkedMDBS As New Collection

Private Sub Form_Load()

' position the form
With DoCmd
.Restore
.RunCommand acCmdSizeToFitForm
End With

' check and repair the links
CheckandRepairLinks
CompactLinkedMDBS

End Sub

Private Function CanOpenExclusive(ByVal varPath As String) As Boolean
'on error Resume Next
Const FileInUse As Long = 3045
Const FileOpenedExclusively As Long = 3356
Dim dbe As PrivDBEngine
Dim dbs As Database
Set dbe = New PrivDBEngine
Set dbs = dbe(0).OpenDatabase(varPath, True)
If dbs Is Nothing Then
If (Err = FileInUse Or Err = FileOpenedExclusively) Then
CanOpenExclusive = False
Else
MsgBox "Error: " & Err & ": " & vbCrLf & Err.Description
End If
Else
CanOpenExclusive = True
dbs.Close
End If
Set dbs = Nothing
Set dbe = Nothing
End Function

Private Sub CheckandRepairLinks(Optional ByRef dbs As Database)

Dim ButtonSelected As Long
Dim bytPath As Byte
Dim DbsWasPassed As Boolean
Dim NewPath As String
Dim OldPath As String
Dim TableDefinition As TableDef

' display relinking message
'lblVerifyingLocationofLinkedTables.Visible = True
DoEvents

If dbs Is Nothing Then
Set dbs = DBEngine(0)(0)
Else
' note if the DataBase was passed
DbsWasPassed = True
End If

' refresh the tabledefs collection
dbs.TableDefs.Refresh

' get collction of linked mdbs
Set colDistinctLinkedMDBS = GetLinkedMdbs(dbs)

' use it
With colDistinctLinkedMDBS

' if it has items then relink those files
If .Count <> 0 Then

For bytPath = 1 To .Count

OldPath = .Item(bytPath)

' check to see if the path can be found
If Not FileFound(OldPath) Then

' if not ask the operator what to do about the
missing link
If MsgBox("The link to " & OldPath & " Is Broken!" _
& vbCrLf _
& vbCrLf _
& "OK to Find " _
& vbCrLf _
& vbCrLf _
& "Cancel to Exit Link Checking", _
vbExclamation Or vbOKCancel) = vbOK Then

' if we want to find a new link then
' call the API function to get the new path and
file
NewPath = GetFile(OldPath)

' if a new path is chosen then
' change the connect for every table usig the old
connect
If NewPath <> "" Then

For Each TableDefinition In dbs.TableDefs
With TableDefinition
If .Connect = ";Database=" & OldPath Then
.Connect = ";Database=" & NewPath
Err = 0
'on error Resume Next
.RefreshLink
' if we have a new path and file
' and still get an error
' just notify the operator
' it will have to be reconciled in
the UI
If Err <> 0 Then MsgBox
Err.Description
End If
End With
Next TableDefinition

Else

' if no file was chosen
' give operator choice of continuing or
exiting

If MsgBox("No File was Chosen!" _
& vbCrLf _
& vbCrLf _
& "OK to Continue " _
& vbCrLf _
& vbCrLf _
& "Cancel to Exit Link Checking", _
, vbInformation Or vbOKCancel) _
= vbCancel Then GoTo CheckandRepairLinksExit

End If

End If

End If

Next bytPath

Else

' no records means we're done
GoTo CheckandRepairLinksExit

End If

End With

CheckandRepairLinksExit:

' don't release the database variable
' if it was passed to us
If Not DbsWasPassed Then Set dbs = Nothing
Exit Sub

CheckandRepairLinksErr:
MsgBox Err.Description, vbCritical, "FFDBA"
Resume CheckandRepairLinksExit

End Sub

Private Sub CompactLinkedMDBS(Optional ByRef dbs As Database)

Dim DbsWasPassed As Boolean
Dim varPath As Variant

' display compacting message
lblVerifyingLocationofLinkedTables.Visible = False
lblCompactingLinkedTables.Visible = True
DoEvents

If dbs Is Nothing Then
Set dbs = DBEngine(0)(0)
Else
' note if the DataBase was passed
DbsWasPassed = True
End If

' if collection empty then fill it
' If colDistinctLinkedMDBS Is Nothing Then Set colDistinctLinkedMDBS
= GetLinkedMdbs(dbs)

' change 2001 03 16
' refill the collection regardless
Set colDistinctLinkedMDBS = GetLinkedMdbs(dbs)

' compact the paths in the collection
For Each varPath In colDistinctLinkedMDBS
If FileFound(varPath) And CanOpenExclusive(varPath) Then
CompactMDB (varPath)
Next varPath

' don't release the database variable
' if it was passed to us
If Not DbsWasPassed Then Set dbs = Nothing

' release the collection and close the form
Set colDistinctLinkedMDBS = Nothing
DoCmd.Close acForm, Me.Name

End Sub

Private Sub CompactMDB(ByVal vStrPath As String)
Dim StrToPath As String
Dim bytAttribute As Byte
StrToPath = strTran(vStrPath, ".mdb", "") & " Compacted.mdb"
DBEngine.CompactDatabase vStrPath, StrToPath
bytAttribute = GetAttr(vStrPath)
If bytAttribute And vbReadOnly = vbReadOnly Then SetAttr vStrPath,
bytAttribute And Not vbReadOnly
FileCopy StrToPath, vStrPath
SetAttr vStrPath, bytAttribute
If Dir(vStrPath) <> "" Then Kill StrToPath
End Sub

Private Function Directory(ByVal FullPath As String) As String
If Right(FullPath, 1) = "\" Then
Directory = FullPath
Else
Directory = Directory(Left(FullPath, Len(FullPath) - 1))
End If
End Function

Private Function FileFound(ByVal strFullPath As String) As Boolean
Dim lngFileName As Long
'on error Resume Next
Err = 0
lngFileName = Len(Dir$(strFullPath))
FileFound = (Err.Number = 0) And (lngFileName <> 0)
End Function

Private Function GetFile(Optional InitialDir As String, _
Optional FilterMessage As String = "JET Files", _
Optional FilterSkelton As String = "*.mdb", _
Optional File As String = "*.mdb", _
Optional Title As String = "Use the Open Button to Select") As String
GetFile = GetPath(InitialDir, FilterMessage, FilterSkelton, File,
Title)
End Function

Private Function GetPath( _
Optional InitialDir As String, _
Optional FilterMessage As String = "Choose Folder Only", _
Optional FilterSkelton As String = "*|*", _
Optional File As String = "Folders Only", _
Optional Title As String = "Use the Open Button to Select") As String
Dim CommDlgError As Long
Dim OFN As OPENFILENAME
If Len(InitialDir) = 0 Then InitialDir = CurDir$()
With OFN
.lStructSize = Len(OFN)
.lpstrFilter = FilterMessage & vbNullChar & FilterSkelton &
String(2, vbNullChar)
.lpstrFile = File & String(MAX_PATH - Len(File), vbNullChar)
.nMaxFile = MAX_PATH
.lpstrInitialDir = InitialDir & vbNullChar
.lpstrTitle = Title
.flags = OFN_HIDEREADONLY Or OFN_NOCHANGEDIR Or OFN_SHAREAWARE
If GetOpenFileName(OFN) <> 0 Then
If FilterSkelton = "*|*" Then
GetPath = Left$(.lpstrFile, .nFileOffset)
Else
GetPath = .lpstrFile
End If
GetPath = Left$(GetPath, InStr(GetPath, vbNullChar) - 1)
Else
CommDlgError = CommDlgExtendedError
' if not just a cancel
If CommDlgError <> 0 Then
MsgBox "Common Dialog Error # " & CommDlgError _
& vbCrLf _
& vbCrLf _
& "Consult Common Dialog Documumentation" _
& vbCrLf _
& "(in MSDN Library)" _
& vbCrLf _
& vbCrLf _
& "for meaning.", _
vbCritical, _
"FFDBA"
End If
End If
End With
End Function

Private Function GetLinkedMdbs(ByRef dbs As Database) As Collection
Dim col As New Collection
Dim strPath As String
Dim tdf As TableDef
Dim bytPath As Byte
For Each tdf In dbs.TableDefs
With tdf
If Left(.Connect, 10) = ";DATABASE=" Then
strPath = Mid(.Connect, 11)
With col
If .Count = 0 Then
.Add strPath
Else
For bytPath = 1 To .Count
If strPath < .Item(bytPath) Then
.Add strPath, , bytPath
Exit For
ElseIf strPath = .Item(bytPath) Then
Exit For
End If
Next bytPath
If bytPath = .Count + 1 Then .Add strPath
End If
End With
End If
End With
Next tdf
Set GetLinkedMdbs = col
End Function

Private Function strTran( _
ByVal vStrReplaceIn As String, _
ByVal vStrReplaceWhat As String, _
ByVal vStrReplaceWith As String, _
Optional ByVal vLngCompareMethod As Long = vbTextCompare) As String
Dim lngPosition As Long
lngPosition = InStr(1, vStrReplaceIn, vStrReplaceWhat,
vLngCompareMethod)
Do While lngPosition <> 0
strTran = strTran & Left(vStrReplaceIn, lngPosition - 1) &
vStrReplaceWith
vStrReplaceIn = Mid(vStrReplaceIn, lngPosition + Len
(vStrReplaceWhat))
lngPosition = InStr(1, vStrReplaceIn, vStrReplaceWhat,
vLngCompareMethod)
Loop
strTran = strTran & vStrReplaceIn
End Function

--
lyle fairfield
.

Relevant Pages

  • Re: Incompatibility between Access 2003 and Access 2002
    ... Private WithEvents mlst As ListBox ... Private mot As ObjectType ... Public DisplayField As String ... Dim prm As DAO.Parameter ...
    (microsoft.public.access.modulesdaovba)
  • Re: FileSystemWatcher advice required please
    ... Private ArchiveImport As String ... Private FilesToProcess As ProcessFiles ... Public Sub Main ... Dim NoVersion As New Collection ...
    (microsoft.public.dotnet.framework)
  • Re: Is there a way to prevent a RichTextBox from scrolling?
    ... Private _isRegex As Boolean ... Public Sub New(ByVal thispattern As String, ... Dim entry As tDict ...
    (microsoft.public.dotnet.framework.windowsforms.controls)
  • MAPI Emails from Access
    ... I realize this code is quite long, but could someone take a look at the sub ... Private Const mcERR_DOH = vbObjectError + 10000 ... Private mstStatus As String ... Dim db As Database, rs As Recordset ...
    (microsoft.public.access.formscoding)
  • Re: File attributes
    ... Private Declare Function GetFullPathName Lib "kernel32" Alias ... ByVal lpFileName As String, _ ... Dim Buffer As String ... Private Const VOS_UNKNOWN = &H0 ...
    (microsoft.public.excel.programming)