I have password protected the back end of my split database. Works well when I re linked the front end. However, I am unable to change the links UNC using code. Do I have to live with hard directory refs or is there a tweak I need to make to the UNC code I am using. Curently when I use the function, I get the message that it has been done but it does not happen.
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\Stores_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
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\Stores_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