If this is your first visit, be sure to check out the FAQ by clicking the link above. You may have to register before you can post: click the register link above to proceed. To start viewing messages, select the forum that you want to visit from the selection below. |
|
|
Thread Tools | Display Modes |
#1
|
|||
|
|||
Split DB Path to BE Code
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 -- Foxy |
#2
|
|||
|
|||
Split DB Path to BE Code
I'm wondering would it have anything to do with a table having an attachment
field? This is a 2007 access db. -- Foxy "Fox" wrote: 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 |
#3
|
|||
|
|||
Split DB Path to BE Code
I see you are deleting tables and then transfering tables.
Here is a way where you just change the connection string. And one way to do it is get the existing connection string strConnect then replace the path as the strConnect2. With CurrentDb strConn = tdf1.Connect If strConnect = strConn Then ElseIf strConnect2 = strConn Then Else tdf1.Connect = strConnect2 tdf1.RefreshLink 'CurrentDb.TableDefs.Append tdf1 Cannot append because it has the same name. End If End With I have done this with tables having hyperlink fields and memos. I confess I don't know about attachments. Stephen Rasey Houston |
#4
|
|||
|
|||
Split DB Path to BE Code
Hey Stephen,
Thanks for the info! I threw out that code because I found a little db that does it all without having to change code or anything. The guy from J Street found my post and directed me to his site. So if you need a relinker...this is the one to use for sure!!! free J Street Access Relinker at: http://www.jstreettech.com/downloads -- Foxy "Stephen Rasey" wrote: I see you are deleting tables and then transfering tables. Here is a way where you just change the connection string. And one way to do it is get the existing connection string strConnect then replace the path as the strConnect2. With CurrentDb strConn = tdf1.Connect If strConnect = strConn Then ElseIf strConnect2 = strConn Then Else tdf1.Connect = strConnect2 tdf1.RefreshLink 'CurrentDb.TableDefs.Append tdf1 Cannot append because it has the same name. End If End With I have done this with tables having hyperlink fields and memos. I confess I don't know about attachments. Stephen Rasey Houston |
Thread Tools | |
Display Modes | |
|
|