Option Compare Database
Option Explicit
Declare Function WNetGetConnection32 _
Lib "mpr.dll" _
Alias "WNetGetConnectionA" ( _
ByVal lpszLocalName As String, _
ByVal lpszRemoteName As String, _
lSize As Long) _
As Long
'// 32-bit declarations:
Dim lpszRemoteName As String
'Dim lSize As Long
'// Use for the return value of WNetGetConnection() API.
Const NO_ERROR As Long = 0
'// The size used for the string buffer. Adjust this if you
'// need a larger buffer.
Const lBUFFER_SIZE As Long = 1052
Function FindLinkedTables(ByVal strDBPath As String, ByVal strWorkGroup As String, ByVal strUser As String, ByVal strPassword As String) As Boolean
Dim db As DAO.Database
Dim tdLoop As DAO.TableDef
Dim strSQL As String
Dim strLinkedPath As String
Dim strUNC As String
Dim wrkJet As DAO.Workspace
Dim pdbeNew As PrivDBEngine
'On Error GoTo errorpub
If strWorkGroup <> "" Then
Set pdbeNew = New PrivDBEngine
With pdbeNew
.SystemDB = strWorkGroup
.DefaultUser = strUser
.DefaultPassword = strPassword
End With
Set wrkJet = pdbeNew.Workspaces(0)
Set db = wrkJet.OpenDatabase(strDBPath)
Else
Set db = OpenDatabase(strDBPath)
End If
' Open the connection
For Each tdLoop In db.TableDefs
'Debug.Print tdLoop.Connect
If Left(tdLoop.Connect, 10) = ";DATABASE=" Then
strLinkedPath = Right(tdLoop.Connect, Len(tdLoop.Connect) - 10)
If Left(strLinkedPath, 2) <> "\\" Then
'convert to UNC
strUNC = Trim(fnUNCPath(Left(strLinkedPath, 1)))
If InStr(1, strUNC, Chr(0)) > 1 Then
strUNC = Left(strUNC, InStr(1, strUNC, Chr(0)) - 1)
End If
strUNC = Left(strUNC, Len(strUNC) - 1)
strLinkedPath = strUNC & Right(strLinkedPath, Len(strLinkedPath) - 2)
End If
strSQL = "INSERT INTO tbl_links ( DatabasePath, LinkedTablePath ) SELECT '" & strDBPath & "' AS TableName, '" & strLinkedPath & "' AS TableLink;"
CurrentDb.Execute strSQL
End If
Next
Set db = Nothing
Set wrkJet = Nothing
Set pdbeNew = Nothing
FindLinkedTables = True
Exit Function
errorpub:
MsgBox Err.Number & " " & Err.Description
Set db = Nothing
Set wrkJet = Nothing
Set pdbeNew = Nothing
FindLinkedTables = False
End Function
Sub FindLinkedAll()
Dim rs As DAO.Recordset
Set rs = CurrentDb.OpenRecordset("SELECT * FROM tbl_Applications")
Do Until rs.EOF
If rs("Ignore") = False And rs("Completed") = False Then
rs.Edit
rs("Completed") = FindLinkedTables(rs("DBPath"), Nz(rs("Workgroup"), ""), Nz(rs("User"), ""), Nz(rs("Password"), ""))
rs.Update
End If
rs.MoveNext
Loop
Set rs = Nothing
End Sub
Function fnUNCPath(strDriveLetter As String) As String
'// Takes specified Local Drive Letter
'// eg E,D,H Etc and converts to UNC
Dim cbRemoteName As Long
Dim lStatus As Long
'// Add a colon to the drive letter entered.
strDriveLetter = Left(strDriveLetter, 1) & ":"
'// Specifies the size in charaters of the buffer.
cbRemoteName = lBUFFER_SIZE
'// Prepare a string variable by padding spaces.
lpszRemoteName = lpszRemoteName & Space(lBUFFER_SIZE)
'// Return the UNC path (eg.\\Server\Share).
lStatus = WNetGetConnection32( _
strDriveLetter, _
lpszRemoteName, _
cbRemoteName)
'// Has WNetGetConnection() succeeded.
'// WNetGetConnection()returns 0 (NO_ERROR)
'// if it succesfully retrieves the UNC path.
If lStatus = NO_ERROR Then
'// Get UNC path.
fnUNCPath = lpszRemoteName
Else
'// Unable to obtain the UNC path.
fnUNCPath = strDriveLetter & ":"
End If
End Function
