UNC Links (1 Viewer)

Option Compare Database
Option Explicit

Declare Function apiWNetGetConnection Lib "mpr.dll" Alias "WNetGetConnectionA" _
  (ByVal strLocalName As String, ByVal strRemoteName As String, _
   ByRef rlngRemoteNameLen As Long) As Long

Private Function TrimNull(ByVal strItem As String) As String
Dim intPos As Integer
    intPos = InStr(strItem, vbNullChar)
    If intPos > 0 Then
        TrimNull = Left(strItem, intPos - 1)
    Else
        TrimNull = strItem
    End If
End Function

Public Function GetUNC(ByVal strPath As String) As String
'Note, this function will only return the UNC for network drives.
'Non-net drives and errors get the original value returned to them
On Error GoTo Err_GetUNC
    Const lngcBuffer As Long = 257
    Dim strUNCPath As String
    Dim strDrive As String
    If Left(strPath, 2) Like "[a-z, A-Z]:" Then
        strDrive = Left(strPath, 2)
        strUNCPath = strUNCPath & Space(lngcBuffer)
        'The function will automatically fill the strUNCPath unless there
        'is an error (return<>0), fill strPath if error
        If apiWNetGetConnection(strDrive, strUNCPath, lngcBuffer) = 0 Then
            strUNCPath = TrimNull(strUNCPath) & Mid(strPath, 3)
        Else
            strUNCPath = strPath
        End If
    End If
    
        If Len(Trim(strUNCPath)) = 0 Then strUNCPath = strPath
    GetUNC = strUNCPath
Exit_GetUNC:
    Exit Function
Err_GetUNC:
    MsgBox "Error " & err.Number & " " & err.Description
    Resume Exit_GetUNC
End Function


Function SetUNCLink() As Boolean
'Date:          Wednesday, 20 August 2003 2:12:04 PM
'Author:        Stephen Cooper
'Email:         stephen.cooper@xxx.com.au
'Ph:            8963
'In parameters
'Output
'Description:   Set the linked tables to UNC paths
'Calls:
'Notes:         Generally called in the startup forms on open
'Example:       Form_OnOpen SetUNCLink
'Modified:      12 Sep 2007. Had it so that it would look at ini file for backend path

On Error GoTo HandleError:

SetUNCLink = True

Dim strErrorMsg As String
Dim varReturn As Variant
Dim strMessage As String
Dim db As DAO.Database
Dim tdf As DAO.TableDef
Dim strTableName As String
Dim strBEDataBase As String

Set db = CurrentDb

strBEDataBase = "K:\Zircon\Data\Zircon_be.mdb"

For Each tdf In db.TableDefs
    'Check it is a linked table
    With tdf
        'Dont bother relinking to temp tables
        If InStr(1, .Connect, "TempWorkTables") = 0 Then
            If Len(.Connect) > 0 Then
                'Only reconnect Access tables, not ODBC
                If Left(.Connect, 10) = ";DATABASE=" Then
                    If Left(.Connect, 1) <> "~" Then
                        strTableName = .Name
                        strMessage = "Relinking " & .Name
                        'SplashLink , strMessage, strMessage
                        strErrorMsg = "Connecting to - " & .Connect
                        .Connect = ";DATABASE=" & GetUNC(strBEDataBase)
                        .RefreshLink
                    End If 'Left(.Connect, 1) <> "~"
                End If 'Left(.Connect, 10) = ";DATABASE="
            End If 'Len(.Connect) > 0
        End If 'InStr(1, .Connect, "TempWorkTables") = 0
    End With 'tdf
Next tdf

db.TableDefs.Refresh

MsgBox ("All done")


ExitHere:
    On Error Resume Next
    'Close all recordsets etc here
    varReturn = SysCmd(acSysCmdClearStatus)
    'SplashLink , , , True
    Exit Function

HandleError:
    Select Case err.Number
        Case 3042
            'Out of MSDOs handles - generally means they dont have access to a drive
            MsgBox "Please ensure you have access to all the required drive mappings. Please contact support if you are unsure " & vbCrLf & "Error msg = " & strErrorMsg, vbCritical, "Mapping error"
            'still log it, as the user will likely lose the error
            'LogError "SetUNCLink|" & CurrentProject.Name & "|" & strErrorMsg & "|" & err.Number & " - " & err.Description
            Resume Next
        Case 3011
            'Cant find table - give message and move on. Message will mean that should eventually get deleted
            MsgBox "Table " & strTableName & " could not be found. Please check with master copy if table should be deleted", vbCritical + vbOKOnly, "Missing table"
            Resume Next
        Case Else
            'LogError "SetUNCLink|" & CurrentProject.Name & "|" & strErrorMsg & "|" & err.Number & " - " & err.Description
            MsgBox strErrorMsg & " " & err.Number & " " & err.Description, vbInformation, "Error"
            SetUNCLink = False
            Resume ExitHere
    End Select

End Function

 If Left(.Connect, 10) = ";DATABASE=" Then
                    If Left(.Connect, 1) <> "~" Then
                        strTableName = .Name
                        strMessage = "Relinking " & .Name
                        'SplashLink , strMessage, strMessage
                        strErrorMsg = "Connecting to - " & .Connect
                        [COLOR=red].Connect = ";DATABASE=" & GetUNC(strBEDataBase)
[/COLOR]                        .RefreshLink
                    End If 'Left(.Connect, 1) <> "~"
                End If 'Left(.Connect, 10) = ";DATABASE="