F
Fox
I have a DB that I Split and the FE and the BE reside on the local machine.
I have a procedure that will find the location of the BE database when
installed on another user computer.
I created a form (form1) put the first bit of code behind it then created a
module called MainMod and added then next bit of code . I load the FE
and BE in correct folders on a different PC and all but one table is
located...the table Projectstbl is still looking for the User/My Document/My
Jewelry Projects/My
Jewelry Data.accdb file.... from the original pc.
Is there something missing in my code to cause this problem with only one
table?
Private Sub Form_Load()
Form_Form1.Visible = False
Dim Result As Boolean
Dim myCurrentPath As String
myCurrentPath = GetSpecialFolder(CSIDL_MY_DOCUMENTS)
'mycurrentpath = application.
'sample call:
Result = LinkTables(myCurrentPath & "\My Jewelry Projects\My Jewelry
Data.accdb")
If Result = True Then
'MsgBox ("DB Links successfully refreshed!")
DoCmd.OpenForm "SwitchBoard"
DoCmd.Close acForm, "Form1"
Else
MsgBox ("DB Links refresh failed!")
End If
End Sub
MainMon Code:
Option Compare Database
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Windows API Declares
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Declare Function CloseHandle Lib "kernel32" _
(ByVal hObject As Long) As Long
Private Declare Function OpenProcess Lib "kernel32" ( _
ByVal dwDesiredAccess As Long, _
ByVal bInheritHandle As Long, _
ByVal dwProcessId As Long) As Long
Private Declare Function GetCurrentThread Lib "kernel32" () As Long
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
Private Declare Function OpenProcessToken Lib "advapi32.dll" ( _
ByVal ProcessHandle As Long, _
ByVal DesiredAccess As Long, _
ByRef TokenHandle As Long) As Long
Private Declare Function SHGetFolderPath Lib "shell32.dll" Alias
"SHGetFolderPathA" ( _
ByVal HWnd As Long, _
ByVal csidl As Long, _
ByVal hToken As Long, _
ByVal dwFlags As Long, _
ByVal pszPath As String) As Long
Private Declare Function GetUserProfileDirectory Lib "userenv.dll" Alias
"GetUserProfileDirectoryA" ( _
ByVal hToken As Long, _
ByVal lpProfileDir As String, _
ByRef lpcchSize As Long) As Long
Private Declare Function FormatMessage Lib "kernel32" _
Alias "FormatMessageA" ( _
ByVal dwFlags As Long, _
ByVal lpSource As Any, _
ByVal dwMessageId As Long, _
ByVal dwLanguageId As Long, _
ByVal lpBuffer As String, _
ByVal nSize As Long, _
ByRef Arguments As Long) As Long
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Misc Constants
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Const MAX_PATH = 260&
Private Const S_OK = 0&
Private Const E_INVALIDARG As Long = &H80070057
Private Const S_FALSE As Long = &H1 ' odd but true that S_FALSE would be 1.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Used By OpenProcessToken and OpenProcess
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Const TOKEN_QUERY As Long = &H8
Private Const TOKEN_QUERY_SOURCE As Long = &H10
Private Const READ_CONTROL As Long = &H20000
Private Const STANDARD_RIGHTS_READ As Long = (READ_CONTROL)
Private Const TOKEN_READ As Long = (STANDARD_RIGHTS_READ Or TOKEN_QUERY)
Private Const SYNCHRONIZE = &H100000
Private Const PROCESS_VM_READ As Long = (&H10)
Private Const PROCESS_QUERY_INFORMATION As Long = (&H400)
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' used by FormatMessage
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Const FORMAT_MESSAGE_ALLOCATE_BUFFER = &H100
Private Const FORMAT_MESSAGE_ARGUMENT_ARRAY = &H2000
Private Const FORMAT_MESSAGE_FROM_HMODULE = &H800
Private Const FORMAT_MESSAGE_FROM_STRING = &H400
Private Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000
Private Const FORMAT_MESSAGE_IGNORE_INSERTS = &H200
Private Const FORMAT_MESSAGE_MAX_WIDTH_MASK = &HFF
Private Const FORMAT_MESSAGE_TEXT_LEN = &HA0
''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' CSIDL Constants of various folder names.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Const CSIDL_ADMINTOOLS As Long = &H30
Public Const CSIDL_ALTSTARTUP As Long = &H1D
Public Const CSIDL_APPDATA As Long = &H1A
Public Const CSIDL_BITBUCKET As Long = &HA
Public Const CSIDL_COMMON_ADMINTOOLS As Long = &H2F
Public Const CSIDL_COMMON_ALTSTARTUP As Long = &H1E
Public Const CSIDL_COMMON_APPDATA As Long = &H23
Public Const CSIDL_COMMON_DESKTOPDIRECTORY As Long = &H19
Public Const CSIDL_COMMON_DOCUMENTS As Long = &H2E
Public Const CSIDL_COMMON_FAVORITES As Long = &H1F
Public Const CSIDL_COMMON_PROGRAMS As Long = &H17
Public Const CSIDL_COMMON_STARTMENU As Long = &H16
Public Const CSIDL_COMMON_STARTUP As Long = &H18
Public Const CSIDL_COMMON_TEMPLATES As Long = &H2D
Public Const CSIDL_CONNECTIONS As Long = &H31
Public Const CSIDL_CONTROLS As Long = &H3
Public Const CSIDL_COOKIES As Long = &H21
Public Const CSIDL_DESKTOP As Long = &H0
Public Const CSIDL_DESKTOPDIRECTORY As Long = &H10
Public Const CSIDL_DRIVES As Long = &H11
Public Const CSIDL_FAVORITES As Long = &H6
Public Const CSIDL_FLAG_CREATE As Long = &H8000
Public Const CSIDL_FLAG_DONT_VERIFY As Long = &H4000
Public Const CSIDL_FLAG_MASK As Long = &HFF00&
Public Const CSIDL_FLAG_PFTI_TRACKTARGET As Long = CSIDL_FLAG_DONT_VERIFY
Public Const CSIDL_FONTS As Long = &H14
Public Const CSIDL_HISTORY As Long = &H22
Public Const CSIDL_INTERNET As Long = &H1
Public Const CSIDL_INTERNET_CACHE As Long = &H20
Public Const CSIDL_LOCAL_APPDATA As Long = &H1C
Public Const CSIDL_MYPICTURES As Long = &H27
Public Const CSIDL_NETHOOD As Long = &H13
Public Const CSIDL_NETWORK As Long = &H12
Public Const CSIDL_PERSONAL As Long = &H5 ' My Documents
Public Const CSIDL_MY_DOCUMENTS As Long = &H5
Public Const CSIDL_PRINTERS As Long = &H4
Public Const CSIDL_PRINTHOOD As Long = &H1B
Public Const CSIDL_PROFILE As Long = &H28
Public Const CSIDL_PROGRAM_FILES As Long = &H26
Public Const CSIDL_PROGRAM_FILES_COMMON As Long = &H2B
Public Const CSIDL_PROGRAM_FILES_COMMONX86 As Long = &H2C
Public Const CSIDL_PROGRAM_FILESX86 As Long = &H2A
Public Const CSIDL_PROGRAMS As Long = &H2
Public Const CSIDL_RECENT As Long = &H8
Public Const CSIDL_SENDTO As Long = &H9
Public Const CSIDL_STARTMENU As Long = &HB
Public Const CSIDL_STARTUP As Long = &H7
Public Const CSIDL_SYSTEM As Long = &H25
Public Const CSIDL_SYSTEMX86 As Long = &H29
Public Const CSIDL_TEMPLATES As Long = &H15
Public Const CSIDL_WINDOWS As Long = &H24
Public Const PRIV_PAL_FUNC As Long = &H0
Public Const CSIR_FUNC As Long = (PRIV_PAL_FUNC Or &HD)
Function LinkTables(DbPath As String) As Boolean
'This links to all the tables that reside in DbPath,
' whether or not they already reside in this database.
'This works when linking to an Access .mdb file, not to ODBC.
'This keeps the same table name on the front end as on the back end.
Dim rs As Recordset
On Error Resume Next
'get tables in back end database
Set rs = CurrentDb.OpenRecordset("SELECT Name " & _
"FROM MSysObjects IN '" & DbPath & "' "
& _
"WHERE Type=1 AND Flags=0")
If Err <> 0 Then Exit Function
'link the tables
While Not rs.EOF
If DbPath <> Nz(DLookup("Database", "MSysObjects", "Name='" &
rs!Name & "' And Type=6")) Then
'delete old link, assuming front and back end table have the
same name
DoCmd.DeleteObject acTable, rs!Name
'make new link
DoCmd.TransferDatabase acLink, "Microsoft Access", DbPath,
acTable, rs!Name, rs!Name
End If
rs.MoveNext
Wend
rs.Close
LinkTables = True
End Function
Public Function TrimToNull(Text As String) As String
Dim N As Long
N = InStr(1, Text, vbNullChar)
If N Then
TrimToNull = Left(Text, N - 1)
Else
TrimToNull = Text
End If
End Function
Public Function GetUserProfileFolder()
Dim Res As Long
Dim CurrentProcessHandle As Long
Dim TokenHandle As Long
Dim UserProfileDirectory As String
Dim LLen As Long
Dim Pos As Integer
''''''''''''''''''''''''''''''''''''''''''''''''''''
' Initialize the string to receive the folder name
''''''''''''''''''''''''''''''''''''''''''''''''''''
UserProfileDirectory = String(MAX_PATH, " ")
LLen = Len(UserProfileDirectory)
''''''''''''''''''''''''''''''''''''''''''''''''''''
' Get the pseudo-handle of the current process
''''''''''''''''''''''''''''''''''''''''''''''''''''
CurrentProcessHandle = GetCurrentProcess()
''''''''''''''''''''''''''''''''''''''''''''''''''''
' Open the access token of the process
''''''''''''''''''''''''''''''''''''''''''''''''''''
Res = OpenProcessToken(CurrentProcessHandle, TOKEN_READ, TokenHandle)
If Res = 0 Then
MsgBox "ERROR OpenProcessToken " & CStr(Err.LastDllError) & " " &
GetSystemErrorMessageText(Err.LastDllError)
Exit Function
End If
''''''''''''''''''''''''''''''''''''''''''''''''''''
' Get the user's directory
''''''''''''''''''''''''''''''''''''''''''''''''''''
Res = GetUserProfileDirectory(TokenHandle, UserProfileDirectory, LLen)
If Res = 0 Then
CloseHandle CurrentProcessHandle
CloseHandle TokenHandle
MsgBox "ERROR GetUserProfileDirectory " & CStr(Err.LastDllError) & " "
& GetSystemErrorMessageText(Err.LastDllError)
Exit Function
End If
''''''''''''''''''''''''''''''''''''''''''''''''''''
' Trim to null char
''''''''''''''''''''''''''''''''''''''''''''''''''''
UserProfileDirectory = TrimToNull(Text:=UserProfileDirectory)
''''''''''''''''''''''''''''''''''''''''''''''''''''
'Close handles
''''''''''''''''''''''''''''''''''''''''''''''''''''
CloseHandle CurrentProcessHandle
CloseHandle TokenHandle
''''''''''''''''''''''''''''''''''''''''''''''''''''
' Return the result
''''''''''''''''''''''''''''''''''''''''''''''''''''
GetUserProfileFolder = UserProfileDirectory
End Function
Public Function GetSpecialFolder(FolderCSIDL As Long) As String
Dim HWnd As Long
Dim Path As String
Dim Res As Long
Dim ErrNumber As Long
Dim ErrText As String
''''''''''''''''''''''''''''''''''''''''''''
' initialize the path variable
''''''''''''''''''''''''''''''''''''''''''''
Path = String$(MAX_PATH, vbNullChar)
''''''''''''''''''''''''''''''''''''''''''''
' get the folder name
''''''''''''''''''''''''''''''''''''''''''''
Res = SHGetFolderPath(HWnd:=0&, _
csidl:=FolderCSIDL, _
hToken:=0&, _
dwFlags:=0&, _
pszPath:=Path)
Select Case Res
Case S_OK
Path = TrimToNull(Text:=Path)
GetSpecialFolder = Path
Case S_FALSE
MsgBox "The folder code is valid but the folder does not exist."
GetSpecialFolder = vbNullString
Case E_INVALIDARG
MsgBox "The value of FolderCSIDL is not valid."
GetSpecialFolder = vbNullString
Case Else
ErrNumber = Err.LastDllError
ErrText = GetSystemErrorMessageText(Res)
MsgBox "An error occurred." & vbCrLf & _
"System Error: " & CStr(ErrNumber) & vbCrLf & _
"Description: " & ErrText
End Select
End Function
Private Function GetSystemErrorMessageText(ErrorNumber As Long) As String
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' GetSystemErrorMessageText
'
' This function gets the system error message text that corresponds
' to the error code parameter ErrorCode. This value is the value returned
' by Err.LastDLLError or by GetLastError, or occasionally as the returned
' result of a Windows API function.
'
' These are NOT the error numbers returned by Err.Number (for these
' errors, use Err.Description to get the description of the error).
'
' In general, you should use Err.LastDllError rather than GetLastError
' because under some circumstances the value of GetLastError will be
' reset to 0 before the value is returned to VBA. Err.LastDllError will
' always reliably return the last error number raised in an API function.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim ErrorText As String
Dim TextLen As Long
Dim FormatMessageResult As Long
Dim LangID As Long
''''''''''''''''''''''''''''''''
' initialize the variables
''''''''''''''''''''''''''''''''
LangID = 0& 'default language
ErrorText = String$(FORMAT_MESSAGE_TEXT_LEN, vbNullChar)
TextLen = FORMAT_MESSAGE_TEXT_LEN
' Call FormatMessage to get the text of the error message text
' associated with ErrorNumber.
FormatMessageResult = FormatMessage( _
dwFlags:=FORMAT_MESSAGE_FROM_SYSTEM Or _
FORMAT_MESSAGE_IGNORE_INSERTS, _
lpSource:=0&, _
dwMessageId:=ErrorNumber, _
dwLanguageId:=LangID, _
lpBuffer:=ErrorText, _
nSize:=TextLen, _
Arguments:=0&)
If FormatMessageResult = 0& Then
' An error occured. Display the error number, but
' don't call GetSystemErrorMessageText to get the
' text, which would likely cause the error again,
' getting us into a loop.
MsgBox "An error occurred with the FormatMessage" & _
" API functiopn call. Error: " & _
CStr(Err.LastDllError) & _
" Hex(" & Hex(Err.LastDllError) & ")."
GetSystemErrorMessageText = vbNullString
Exit Function
End If
' If FormatMessageResult is not zero, it is the number
' of characters placed in the ErrorText variable.
' Take the left FormatMessageResult characters and
' return that text.
ErrorText = Left$(ErrorText, FormatMessageResult)
GetSystemErrorMessageText = ErrorText
End Function
I have a procedure that will find the location of the BE database when
installed on another user computer.
I created a form (form1) put the first bit of code behind it then created a
module called MainMod and added then next bit of code . I load the FE
and BE in correct folders on a different PC and all but one table is
located...the table Projectstbl is still looking for the User/My Document/My
Jewelry Projects/My
Jewelry Data.accdb file.... from the original pc.
Is there something missing in my code to cause this problem with only one
table?
Private Sub Form_Load()
Form_Form1.Visible = False
Dim Result As Boolean
Dim myCurrentPath As String
myCurrentPath = GetSpecialFolder(CSIDL_MY_DOCUMENTS)
'mycurrentpath = application.
'sample call:
Result = LinkTables(myCurrentPath & "\My Jewelry Projects\My Jewelry
Data.accdb")
If Result = True Then
'MsgBox ("DB Links successfully refreshed!")
DoCmd.OpenForm "SwitchBoard"
DoCmd.Close acForm, "Form1"
Else
MsgBox ("DB Links refresh failed!")
End If
End Sub
MainMon Code:
Option Compare Database
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Windows API Declares
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Declare Function CloseHandle Lib "kernel32" _
(ByVal hObject As Long) As Long
Private Declare Function OpenProcess Lib "kernel32" ( _
ByVal dwDesiredAccess As Long, _
ByVal bInheritHandle As Long, _
ByVal dwProcessId As Long) As Long
Private Declare Function GetCurrentThread Lib "kernel32" () As Long
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
Private Declare Function OpenProcessToken Lib "advapi32.dll" ( _
ByVal ProcessHandle As Long, _
ByVal DesiredAccess As Long, _
ByRef TokenHandle As Long) As Long
Private Declare Function SHGetFolderPath Lib "shell32.dll" Alias
"SHGetFolderPathA" ( _
ByVal HWnd As Long, _
ByVal csidl As Long, _
ByVal hToken As Long, _
ByVal dwFlags As Long, _
ByVal pszPath As String) As Long
Private Declare Function GetUserProfileDirectory Lib "userenv.dll" Alias
"GetUserProfileDirectoryA" ( _
ByVal hToken As Long, _
ByVal lpProfileDir As String, _
ByRef lpcchSize As Long) As Long
Private Declare Function FormatMessage Lib "kernel32" _
Alias "FormatMessageA" ( _
ByVal dwFlags As Long, _
ByVal lpSource As Any, _
ByVal dwMessageId As Long, _
ByVal dwLanguageId As Long, _
ByVal lpBuffer As String, _
ByVal nSize As Long, _
ByRef Arguments As Long) As Long
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Misc Constants
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Const MAX_PATH = 260&
Private Const S_OK = 0&
Private Const E_INVALIDARG As Long = &H80070057
Private Const S_FALSE As Long = &H1 ' odd but true that S_FALSE would be 1.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Used By OpenProcessToken and OpenProcess
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Const TOKEN_QUERY As Long = &H8
Private Const TOKEN_QUERY_SOURCE As Long = &H10
Private Const READ_CONTROL As Long = &H20000
Private Const STANDARD_RIGHTS_READ As Long = (READ_CONTROL)
Private Const TOKEN_READ As Long = (STANDARD_RIGHTS_READ Or TOKEN_QUERY)
Private Const SYNCHRONIZE = &H100000
Private Const PROCESS_VM_READ As Long = (&H10)
Private Const PROCESS_QUERY_INFORMATION As Long = (&H400)
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' used by FormatMessage
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Const FORMAT_MESSAGE_ALLOCATE_BUFFER = &H100
Private Const FORMAT_MESSAGE_ARGUMENT_ARRAY = &H2000
Private Const FORMAT_MESSAGE_FROM_HMODULE = &H800
Private Const FORMAT_MESSAGE_FROM_STRING = &H400
Private Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000
Private Const FORMAT_MESSAGE_IGNORE_INSERTS = &H200
Private Const FORMAT_MESSAGE_MAX_WIDTH_MASK = &HFF
Private Const FORMAT_MESSAGE_TEXT_LEN = &HA0
''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' CSIDL Constants of various folder names.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Const CSIDL_ADMINTOOLS As Long = &H30
Public Const CSIDL_ALTSTARTUP As Long = &H1D
Public Const CSIDL_APPDATA As Long = &H1A
Public Const CSIDL_BITBUCKET As Long = &HA
Public Const CSIDL_COMMON_ADMINTOOLS As Long = &H2F
Public Const CSIDL_COMMON_ALTSTARTUP As Long = &H1E
Public Const CSIDL_COMMON_APPDATA As Long = &H23
Public Const CSIDL_COMMON_DESKTOPDIRECTORY As Long = &H19
Public Const CSIDL_COMMON_DOCUMENTS As Long = &H2E
Public Const CSIDL_COMMON_FAVORITES As Long = &H1F
Public Const CSIDL_COMMON_PROGRAMS As Long = &H17
Public Const CSIDL_COMMON_STARTMENU As Long = &H16
Public Const CSIDL_COMMON_STARTUP As Long = &H18
Public Const CSIDL_COMMON_TEMPLATES As Long = &H2D
Public Const CSIDL_CONNECTIONS As Long = &H31
Public Const CSIDL_CONTROLS As Long = &H3
Public Const CSIDL_COOKIES As Long = &H21
Public Const CSIDL_DESKTOP As Long = &H0
Public Const CSIDL_DESKTOPDIRECTORY As Long = &H10
Public Const CSIDL_DRIVES As Long = &H11
Public Const CSIDL_FAVORITES As Long = &H6
Public Const CSIDL_FLAG_CREATE As Long = &H8000
Public Const CSIDL_FLAG_DONT_VERIFY As Long = &H4000
Public Const CSIDL_FLAG_MASK As Long = &HFF00&
Public Const CSIDL_FLAG_PFTI_TRACKTARGET As Long = CSIDL_FLAG_DONT_VERIFY
Public Const CSIDL_FONTS As Long = &H14
Public Const CSIDL_HISTORY As Long = &H22
Public Const CSIDL_INTERNET As Long = &H1
Public Const CSIDL_INTERNET_CACHE As Long = &H20
Public Const CSIDL_LOCAL_APPDATA As Long = &H1C
Public Const CSIDL_MYPICTURES As Long = &H27
Public Const CSIDL_NETHOOD As Long = &H13
Public Const CSIDL_NETWORK As Long = &H12
Public Const CSIDL_PERSONAL As Long = &H5 ' My Documents
Public Const CSIDL_MY_DOCUMENTS As Long = &H5
Public Const CSIDL_PRINTERS As Long = &H4
Public Const CSIDL_PRINTHOOD As Long = &H1B
Public Const CSIDL_PROFILE As Long = &H28
Public Const CSIDL_PROGRAM_FILES As Long = &H26
Public Const CSIDL_PROGRAM_FILES_COMMON As Long = &H2B
Public Const CSIDL_PROGRAM_FILES_COMMONX86 As Long = &H2C
Public Const CSIDL_PROGRAM_FILESX86 As Long = &H2A
Public Const CSIDL_PROGRAMS As Long = &H2
Public Const CSIDL_RECENT As Long = &H8
Public Const CSIDL_SENDTO As Long = &H9
Public Const CSIDL_STARTMENU As Long = &HB
Public Const CSIDL_STARTUP As Long = &H7
Public Const CSIDL_SYSTEM As Long = &H25
Public Const CSIDL_SYSTEMX86 As Long = &H29
Public Const CSIDL_TEMPLATES As Long = &H15
Public Const CSIDL_WINDOWS As Long = &H24
Public Const PRIV_PAL_FUNC As Long = &H0
Public Const CSIR_FUNC As Long = (PRIV_PAL_FUNC Or &HD)
Function LinkTables(DbPath As String) As Boolean
'This links to all the tables that reside in DbPath,
' whether or not they already reside in this database.
'This works when linking to an Access .mdb file, not to ODBC.
'This keeps the same table name on the front end as on the back end.
Dim rs As Recordset
On Error Resume Next
'get tables in back end database
Set rs = CurrentDb.OpenRecordset("SELECT Name " & _
"FROM MSysObjects IN '" & DbPath & "' "
& _
"WHERE Type=1 AND Flags=0")
If Err <> 0 Then Exit Function
'link the tables
While Not rs.EOF
If DbPath <> Nz(DLookup("Database", "MSysObjects", "Name='" &
rs!Name & "' And Type=6")) Then
'delete old link, assuming front and back end table have the
same name
DoCmd.DeleteObject acTable, rs!Name
'make new link
DoCmd.TransferDatabase acLink, "Microsoft Access", DbPath,
acTable, rs!Name, rs!Name
End If
rs.MoveNext
Wend
rs.Close
LinkTables = True
End Function
Public Function TrimToNull(Text As String) As String
Dim N As Long
N = InStr(1, Text, vbNullChar)
If N Then
TrimToNull = Left(Text, N - 1)
Else
TrimToNull = Text
End If
End Function
Public Function GetUserProfileFolder()
Dim Res As Long
Dim CurrentProcessHandle As Long
Dim TokenHandle As Long
Dim UserProfileDirectory As String
Dim LLen As Long
Dim Pos As Integer
''''''''''''''''''''''''''''''''''''''''''''''''''''
' Initialize the string to receive the folder name
''''''''''''''''''''''''''''''''''''''''''''''''''''
UserProfileDirectory = String(MAX_PATH, " ")
LLen = Len(UserProfileDirectory)
''''''''''''''''''''''''''''''''''''''''''''''''''''
' Get the pseudo-handle of the current process
''''''''''''''''''''''''''''''''''''''''''''''''''''
CurrentProcessHandle = GetCurrentProcess()
''''''''''''''''''''''''''''''''''''''''''''''''''''
' Open the access token of the process
''''''''''''''''''''''''''''''''''''''''''''''''''''
Res = OpenProcessToken(CurrentProcessHandle, TOKEN_READ, TokenHandle)
If Res = 0 Then
MsgBox "ERROR OpenProcessToken " & CStr(Err.LastDllError) & " " &
GetSystemErrorMessageText(Err.LastDllError)
Exit Function
End If
''''''''''''''''''''''''''''''''''''''''''''''''''''
' Get the user's directory
''''''''''''''''''''''''''''''''''''''''''''''''''''
Res = GetUserProfileDirectory(TokenHandle, UserProfileDirectory, LLen)
If Res = 0 Then
CloseHandle CurrentProcessHandle
CloseHandle TokenHandle
MsgBox "ERROR GetUserProfileDirectory " & CStr(Err.LastDllError) & " "
& GetSystemErrorMessageText(Err.LastDllError)
Exit Function
End If
''''''''''''''''''''''''''''''''''''''''''''''''''''
' Trim to null char
''''''''''''''''''''''''''''''''''''''''''''''''''''
UserProfileDirectory = TrimToNull(Text:=UserProfileDirectory)
''''''''''''''''''''''''''''''''''''''''''''''''''''
'Close handles
''''''''''''''''''''''''''''''''''''''''''''''''''''
CloseHandle CurrentProcessHandle
CloseHandle TokenHandle
''''''''''''''''''''''''''''''''''''''''''''''''''''
' Return the result
''''''''''''''''''''''''''''''''''''''''''''''''''''
GetUserProfileFolder = UserProfileDirectory
End Function
Public Function GetSpecialFolder(FolderCSIDL As Long) As String
Dim HWnd As Long
Dim Path As String
Dim Res As Long
Dim ErrNumber As Long
Dim ErrText As String
''''''''''''''''''''''''''''''''''''''''''''
' initialize the path variable
''''''''''''''''''''''''''''''''''''''''''''
Path = String$(MAX_PATH, vbNullChar)
''''''''''''''''''''''''''''''''''''''''''''
' get the folder name
''''''''''''''''''''''''''''''''''''''''''''
Res = SHGetFolderPath(HWnd:=0&, _
csidl:=FolderCSIDL, _
hToken:=0&, _
dwFlags:=0&, _
pszPath:=Path)
Select Case Res
Case S_OK
Path = TrimToNull(Text:=Path)
GetSpecialFolder = Path
Case S_FALSE
MsgBox "The folder code is valid but the folder does not exist."
GetSpecialFolder = vbNullString
Case E_INVALIDARG
MsgBox "The value of FolderCSIDL is not valid."
GetSpecialFolder = vbNullString
Case Else
ErrNumber = Err.LastDllError
ErrText = GetSystemErrorMessageText(Res)
MsgBox "An error occurred." & vbCrLf & _
"System Error: " & CStr(ErrNumber) & vbCrLf & _
"Description: " & ErrText
End Select
End Function
Private Function GetSystemErrorMessageText(ErrorNumber As Long) As String
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' GetSystemErrorMessageText
'
' This function gets the system error message text that corresponds
' to the error code parameter ErrorCode. This value is the value returned
' by Err.LastDLLError or by GetLastError, or occasionally as the returned
' result of a Windows API function.
'
' These are NOT the error numbers returned by Err.Number (for these
' errors, use Err.Description to get the description of the error).
'
' In general, you should use Err.LastDllError rather than GetLastError
' because under some circumstances the value of GetLastError will be
' reset to 0 before the value is returned to VBA. Err.LastDllError will
' always reliably return the last error number raised in an API function.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim ErrorText As String
Dim TextLen As Long
Dim FormatMessageResult As Long
Dim LangID As Long
''''''''''''''''''''''''''''''''
' initialize the variables
''''''''''''''''''''''''''''''''
LangID = 0& 'default language
ErrorText = String$(FORMAT_MESSAGE_TEXT_LEN, vbNullChar)
TextLen = FORMAT_MESSAGE_TEXT_LEN
' Call FormatMessage to get the text of the error message text
' associated with ErrorNumber.
FormatMessageResult = FormatMessage( _
dwFlags:=FORMAT_MESSAGE_FROM_SYSTEM Or _
FORMAT_MESSAGE_IGNORE_INSERTS, _
lpSource:=0&, _
dwMessageId:=ErrorNumber, _
dwLanguageId:=LangID, _
lpBuffer:=ErrorText, _
nSize:=TextLen, _
Arguments:=0&)
If FormatMessageResult = 0& Then
' An error occured. Display the error number, but
' don't call GetSystemErrorMessageText to get the
' text, which would likely cause the error again,
' getting us into a loop.
MsgBox "An error occurred with the FormatMessage" & _
" API functiopn call. Error: " & _
CStr(Err.LastDllError) & _
" Hex(" & Hex(Err.LastDllError) & ")."
GetSystemErrorMessageText = vbNullString
Exit Function
End If
' If FormatMessageResult is not zero, it is the number
' of characters placed in the ErrorText variable.
' Take the left FormatMessageResult characters and
' return that text.
ErrorText = Left$(ErrorText, FormatMessageResult)
GetSystemErrorMessageText = ErrorText
End Function