On 7 Feb 2005 10:25:32 -0800, "Daveyk0" <da*******@ae.ge.com> wrote:
Hello there,
I have a front end database that I have recently made very many changes
to to allow off-line use. I keep copies of the databases on my hard
drive and link to them rather than the live databases on the network.
Is there a way, via code, when I get back in-house from being on the
road to click a button, and select the backends I want to link to?
I would want to delete all the current links and link to the "live"
database on our network. Currently I do that manually by going to the
Table Object windows and basically deleting all links. Then I
right-mouse click, and link to the live databases.
When I am done, I am linked to about 4 live databases on the network
and one mobile database on my laptop.
I found some old routines on the internet that refreshed the link but
did not handle more than one backend. Those routines are made up of a
lot of hard to understand functions.
Is there an easy ways to do this?
If so, I could click a "Go On-Road button" and link to the copied
database on d:\database and when I get back, click on "Back Home" and
link to the network database instead of the copies (not in addition
to).
Thanks for all your ideas and help!
Dave
Dave,
This is an old table linkage library.
HIH
Tom
Just cut & paste into a module called (Wiz)Link and complile.
Option Compare Database
Option Explicit
Type ParsePathCB ' ParsePath control block
Drive As String ' Drive letter with
terminator (:)
DirName As String ' Directory path name with
terminator(s) (\)
FilName As String ' File name without
terminator(s) (.)
Ext As String ' File name without
terminator(s) (.)
End Type
Type ListCB ' GetList(), CutList()
control block
ActiveFlag As Boolean ' Working on active list
ListLen As Long ' List length
DelimitLen As Long ' Delimitor length
ListPos As Long ' Current list position
DelimitPos As Long ' Current delimitor position
End Type
' The OPENFILENAME structure contains information the operating system
uses to initialize
' the system-defined Open or Save As dialog box. After the user
closes the dialog box,
' the system returns information about the user’s selection in this
structure.
Private Declare Function apiFileDialog Lib "comdlg32.dll" Alias
"GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Type OPENFILENAME
StructSize As Long ' > The size (in bytes) of
this structure
Owner As Long ' > Handle of the owner
window for the dialog box
Instance As Long ' Not used here
Filter As String ' > A pair of null
terminated filter definitions
CustomFilter As Long ' Not used here
MaxCustFilter As Long ' Not used here
FilterIndex As Long ' Not used here
File As String ' < The selected file name
MaxFile As Long ' > The size (in bytes) of
File variable
FileTitle As String ' Not used here
MaxFileTitle As Long ' Not used here
InitialDir As String ' > The initial file
directory
Title As String ' > The title used in the
dialog title bar
Flags As Long ' > Dialog control flags
FileOffset As Integer ' Not used here
FileExtension As Integer ' Not used here
DefExt As String ' Not used here
CustData As Long ' Not used here
Hook As Long ' Not used here
TemplateName As Long ' Not used here
End Type
Private Declare Function apiFolderDialog Lib "shell32.dll" Alias
"SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Private Declare Function apiGetPath Lib "shell32.dll" Alias
"SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String)
As Long
Private Type BROWSEINFO
Owner As Long ' > Handle of the owner
window for the dialog box
Root As Long ' Not used here
DisplayName As String ' Not used here
Title As String ' > The title used in the
dialog title bar
Flags As Long ' > Dialog control flags
FunctionName As Long ' Not used here
Param As Long ' Not used here
Image As Long ' Not used here
End Type
Public Const OFN_READONLY = &H1 ' Causes the Read Only check
box to be checked initially when the dialog box is created. Indicates
the state of the Read Only check box when the dialog box is closed
Public Const OFN_OVERWRITEPROMPT = &H2 ' Causes the Save As dialog
box to generate a message box if the selected file already exists. The
user must confirm whether to overwrite the file
Public Const OFN_HIDEREADONLY = &H4 ' Hides the Read Only check
box
Public Const OFN_NOCHANGEDIR = &H8 ' Causes the dialog box to
set the current directory back to what it was when the dialog box was
called
Public Const OFN_SHOWHELP = &H10 ' Causes the dialog box to
show the Help button. The hwndOwner member must not be NULL if this
option is specified
Public Const OFN_ENABLEHOOK = &H20 ' Enables the hook function
specified in the lpfnHook member
Public Const OFN_ENABLETEMPLATE = &H40 ' Causes the operating
system to create the dialog box by using the dialog box template
identified by the hInstance and lpTemplateName members
Public Const OFN_ENABLETEMPLATEHANDLE = &H80 ' Indicates that the
hInstance member identifies a data block that contains a preloaded
dialog box template. The operating system ignores the lpTemplateName
member if this flag is specified
Public Const OFN_NOVALIDATE = &H100 ' Specifies that the common
dialog boxes allow invalid characters in the returned filename.
Typically, the calling application uses a hook function that checks
the filename by using the FILEOKSTRING registered message. If the text
box in the edit control is empty or contains nothing but spaces, the
lists of files and directories are updated. If the text box in the
edit control contains anything else, the nFileOffset and
nFileExtension members are set to values generated by parsing the
text. No default extension is added to the text, nor is text copied to
the lpstrFileTitle buffer.
' If the value specified by
the nFileOffset member is negative, the filename is invalid. If the
value specified by nFileOffset is not negative, the filename is valid,
and the nFileOffset and nFileExtension members can be used as if the
OFN_NOVALIDATE flag had not been set
Public Const OFN_ALLOWMULTISELECT = &H200 ' Specifies that the File
Name list box allows multiple selections. (If the dialog box is
created by using a private template, the LBS_EXTENDEDSEL constant must
appear in the definition of the File Name list box.)
Public Const OFN_EXTENSIONDIFFERENT = &H400 ' Specifies that the user
typed a filename extension that differs from the extension specified
by the lpstrDefExt member. The function does not set this flag if
lpstrDefExt is NULL
Public Const OFN_PATHMUSTEXIST = &H800 ' Specifies that the user
can type only valid path and filenames. If this flag is set and the
user types an invalid path and filename in the File Name entry field,
the dialog box function displays a warning in a message box
Public Const OFN_FILEMUSTEXIST = &H1000 ' Specifies that the user
can type only names of existing files in the File Name entry field. If
this flag is set and the user enters an invalid filename in the File
Name entry field, the dialog box function displays a warning in a
message box. The setting of this flag causes the OFN_PATHMUSTEXIST
flag to be set
Public Const OFN_CREATEPROMPT = &H2000 ' Specifies that the dialog
box function should ask whether the user wants to create a file that
does not currently exist. (This flag automatically sets the
OFN_PATHMUSTEXIST and OFN_FILEMUSTEXIST flags.)
Public Const OFN_SHAREAWARE = &H4000 ' Specifies that if a call
to the OpenFile function fails because of a network sharing violation,
the error is ignored and the dialog box returns the given filename. If
this flag is not set, the registered message for SHAREVISTRING is sent
to the hook function, with a pointer to a null-terminated string for
the path and filename in the lParam parameter. The hook function
responds with one of the share values
Public Const OFN_NOREADONLYRETURN = &H8000 ' Specifies that the
returned file does not have the Read Only check box checked and is not
in a write-protected directory
Public Const OFN_NOTESTFILECREATE = &H10000 ' Specifies that the file
is not created before the dialog box is closed. This flag should be
set if the application saves the file on a create-nonmodify network
share point. When an application sets this flag, the library does not
check for write protection, a full disk, an open drive door, or
network protection. Applications using this flag must perform file
operations carefully, because a file cannot be reopened once it is
closed
Public Const OFN_NONETWORKBUTTON = &H20000 ' Hides and disables the
Network button
Public Const OFN_NOLONGNAMES = &H40000 ' force no long names for
4.x modules
Public Const OFN_EXPLORER = &H80000 ' new look commdlg
Public Const OFN_NODEREFERENCELINKS = &H100000 '
Public Const OFN_LONGNAMES = &H200000 ' force long names for 3.x
modules
Public Const OFN_SHAREFALLTHROUGH = 2 ' Specifies that the
filename is returned by the dialog box
Public Const OFN_SHARENOWARN = 1 ' Specifies no further
action
Public Const OFN_SHAREWARN = 0 ' Specifies that the user
receives the standard warning message for this error, the same result
as if there were no hook function
Private Declare Function api_GetOpenFileName Lib "comdlg32.dll" Alias
"GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias
"SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String)
As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias
"SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Private Const BIF_RETURNONLYFSDIRS = &H1
Public Function FileDialog(CF As Form, Filter As String, Title As
String, InitDir As String, MustExist As Boolean) As String
' IniDir = "C:\My Documents"
' Title = "Find and Select File"
' Filter = "Microsoft Access Databases (*.mdb)|*.mdb|Microsoft Access
Databases (*.mde)|(*.mde)|"
' FullPath = FileDialog(Me, Filter, Title, IntDir, True)
Dim FD As OPENFILENAME ' open file name structure
Dim ApiRtn As Long ' api call return code
Const OFN_FILEMUSTEXIST = &H1000 ' user can only select
existing files
FD.StructSize = Len(FD) ' set structure length
FD.Owner = CF.Hwnd ' set handle of owner form
FD.Filter = Replace(Filter, "|", Chr(0)) ' set file filter
FD.Title = Title ' set dialog title
If Len(InitDir) > 0 Then ' if initial directory
specified
FD.InitialDir = InitDir ' use specified initial
directory
Else ' if initial directory NOT
specified
FD.InitialDir = MyPath() ' use current directory as
initial directory
End If ' if initial directory
specified
FD.File = Space$(254) ' initialize return file
name buffer (no starting file name)
FD.MaxFile = 255 ' set size of File buffer
If MustExist Then ' if selecting a file, that
file must exist
FD.Flags = OFN_FILEMUSTEXIST ' set dialog flags
End If ' if selecting a file, that
file must exist
ApiRtn = apiFileDialog(FD) ' fire off dialog
If ApiRtn Then ' if file selected, return
file name
ApiRtn = Len(Trim$(FD.File)) - 1 ' length of file name
FileDialog = Left$(FD.File, ApiRtn) ' return file name
Else ' if no file selected
FileDialog = "" ' return no file name
End If ' if file selected
End Function
Public Function FolderDialog(CF As Form, Title As String) As String
' Me.FileSpec = FolderDialog(Me, "What Folder you want to select?")
Dim BI As BROWSEINFO ' browse information
structure
Dim ApiRtn As Long ' api call's return code
Dim Path As String ' selected path
Dim ID As Long ' ID of selected folder
Dim Pos As Integer ' terminator position
Const BIF_RETURNONLYFSDIRS = &H1 ' flag to select directories
only
BI.Owner = CF.Hwnd ' set handle of owner form
BI.Title = Title ' set dialog title
BI.Flags = BIF_RETURNONLYFSDIRS ' set dialog control flags
(select directories)
ID = apiFolderDialog(BI) ' fire off dialog
Path = Space$(512) ' initilize selection
variable
ApiRtn = apiGetPath(ByVal ID, ByVal Path) ' get path form list by ID
If ApiRtn Then ' if user selected path
Pos = InStr(Path, Chr(0)) ' get length of path
FolderDialog = Left$(Path, Pos - 1) ' return path
Else ' if user did NOT select
path (or error)
FolderDialog = "" ' return blank path
End If ' if user selected path
End Function
Public Function MyPath() As String
Dim DB As Database ' current database object
Dim FS As ParsePathCB ' parse path structure
Dim CP As String ' current path
Set DB = CurrentDb ' set this database's object
ParsePath FS, DB.Name ' get this database's full
path
MyPath = FS.Drive & ":" & FS.DirName ' get current path
Set DB = Nothing ' free resources
End Function
Public Sub ParsePath(FSCB As ParsePathCB, ByVal FullPath As String)
' Parses drive, directory, filename, and extension into separate
variables.
' Returns blank drive letter/path if none specified.
Dim i As Integer ' path pointer
Dim FileName As String ' temporary file name buffer
FSCB.Drive = "" ' initilize drive
FSCB.DirName = "" ' initilize directoy name
FSCB.FilName = "" ' initilize file name
FSCB.Ext = "" ' initilize extension
FileName = "" ' initilize file name
' Get drive letter
If Mid$(FullPath, 2, 1) = ":" Then ' if driver terminator found
FSCB.Drive = Left$(FullPath, 1) ' load drive letter
FullPath = Mid$(FullPath, 3) ' load full path
End If ' if driver terminator found
' Get directory name
For i = Len(FullPath) To 1 Step -1 ' find last directory
terminator
If Mid$(FullPath, i, 1) = "\" Then ' if character is last
directory terminator
FileName = Mid$(FullPath, i + 1) ' load file name and
extension
FSCB.DirName = Left$(FullPath, i) ' load directory name
Exit For ' skip next
End If ' if character is last
directory terminator
Next i ' next charactor
If i = 0 Then ' if didn't get directory
FileName = FullPath ' load file name buffer with
full path
End If ' if didn't get directory
' Get File name and extension
If FileName = "." Or FileName = ".." Then ' if file name is a
directory or subdirectory
FSCB.FilName = FileName ' load it as file name
Else ' if file name is NOT a
directory or subdirectory
i = InStr(FileName, ".") ' find file name terminator
If i > 0 Then ' if file name terminator
found
FSCB.FilName = Left$(FileName, i - 1) ' load file name
FSCB.Ext = Mid$(FileName, i) ' load extension
Else ' if file name terminator
NOT found
FSCB.FilName = FileName ' load just file name
End If ' if file name terminator
found
End If ' if file name is a
directory or subdirectory
Exit Sub
End Sub
Public Function ListCount(List As String, Delimitor As String) As Long
' Counts the number of "Delimitor"'s in "List" and returns the number.
Dim ListLen As Long ' Length of list
Dim DelimitLen As Long ' Length of terminator
Dim ListPos As Long ' Current list position
Dim DelimitPos As Long ' Current delimitor position
Dim DelimitCount As Long ' Total number of delimitors
in list
ListLen = Len(List) ' Set list length
DelimitLen = Len(Delimitor) ' Set delimitor length
ListPos = 1 ' Set defualt current list
position
Do ' Count delimitors, Find
delimitor
DelimitPos = InStr(ListPos, List, Delimitor)
If DelimitPos = 0 Then Exit Do ' If NO delimitor found,
Exit Do
DelimitCount = DelimitCount + 1 ' Increament delimitor count
ListPos = DelimitPos + DelimitLen ' Set next current list
postion
Loop Until ListPos >= ListLen ' Next delimitor
ListCount = DelimitCount ' Return delimitor count
End Function
Public Sub ListCut(List As String, Cut As String, Delimitor As String,
CutDelimit As Boolean)
' Cuts from the first character in "List" up to and depending on the
"CutDelimit" flag,
' including the "Delimitor" then loads it into "Cut". The rest of the
List is reloaded
' back into "List".
Dim DelimPos As Long ' Delimitor position
Dim DelimLen As Long ' Delimitor length
DelimLen = Len(Delimitor) ' Set Length of delimitor
DelimPos = InStr(1, List, Delimitor) ' Find delimitor
If DelimPos <> 0 Then ' If Delimitor found
If CutDelimit Then ' If cut delimitor too
Cut = Left$(List, DelimPos + (DelimLen - 1))
Else ' If DON'T cut delimitor too
Cut = Left$(List, DelimPos - 1)
End If ' If cut delimitor too
List = Mid$(List, DelimPos + DelimLen) ' Return rest of list
Else ' If Delimitor NOT found
Cut = "" ' Clear cut
End If ' If Delimitor found
End Sub
Public Function ListGet(LgCB As ListCB, List As String, Member As
String, Delimitor As String, GetDelimit As Boolean) As Boolean
' Gets from the "CB.ListPos" character in "List" up to and depending
on "CutDelimit" flag,
' including the "Delimitor" then loads it into "CB.Cut". The
"CB.ListPos" is then set to
' just past the "Delimitor" so ListGet can be recalled, getting each
member in the "List"
' until the end of the "List" is found. If the end of the "List" end
with a "Delimitor" the
' last call will return into "CB.Cut" a blank string, if the end of
the "List" doesn't end
' with a "Delimitor" the last call will return the remainder of the
"List". The "List" is
' not altered.
If Not LgCB.ActiveFlag Then ' If NOT working on active
list
LgCB.ListLen = Len(List) ' Get Length of new list
LgCB.ListPos = 1 ' Set current list position
LgCB.ActiveFlag = True ' Set working on active list
flag
End If ' If NOT working on active
list
LgCB.DelimitLen = Len(Delimitor) ' Get Length of new
delimitor
' Find delimitor
LgCB.DelimitPos = InStr(LgCB.ListPos, List, Delimitor)
If LgCB.DelimitPos <> 0 Then ' If delimitor found, Get
member
If GetDelimit Then
Member = Mid$(List, LgCB.ListPos, (LgCB.DelimitPos +
LgCB.DelimitLen) - LgCB.ListPos)
Else
Member = Mid$(List, LgCB.ListPos, LgCB.DelimitPos - LgCB.ListPos)
End If
' Set current list position for next get
LgCB.ListPos = LgCB.DelimitPos + LgCB.DelimitLen
ListGet = True ' Signal caller that there
is data to process
Else ' If terminator Not found
If LgCB.ListLen >= LgCB.ListPos Then ' If partial member left in
list
Member = Mid$(List, LgCB.ListPos) ' Return partial list
Else ' If partial line NOT left
in list
Member = "" ' Clear return
End If ' If partial member left in
list
ListGet = False ' Signal caller that there
is NO data to process
LgCB.ActiveFlag = False ' Flag NOT working on active
list
End If ' If terminator found
End Function
Public Function LinkTable(FullPath As String, TableName As String) As
Boolean
Dim DB As Database
Dim TD As TableDef
On Error GoTo ErrorRoute ' error routing
If TableExists(TableName) Then DeleteTable TableName
Set DB = CurrentDb ' link tables to current db
Set TD = DB.CreateTableDef(TableName) ' create new table
TD.Connect = ";DATABASE=" & FullPath ' set server .mdb full path
TD.SourceTableName = TableName ' set table name
DB.TableDefs.Append TD ' add new table
LinkTable = True
Set DB = Nothing
Set TD = Nothing
Exit Function
ErrorRoute:
Err.Clear
LinkTable = False
End Function
Public Sub DeleteTable(TableName As String)
Dim DB As Database
Dim TD As TableDef
Set DB = CurrentDb ' link tables to current db
For Each TD In DB.TableDefs '
If TableName = TD.Name Then DB.TableDefs.Delete TableName: Exit Sub
Next TD
Set DB = Nothing
End Sub
Public Sub UnlinkTables(Tables As String)
Dim Names As String ' table names
Dim LgCB As ListCB ' list get structure
Dim C As Integer ' table count
Dim t As Integer ' tables
C = ListCount(Tables, ",") + 1 ' get number of tables
If Tables <> "" Then ' if tables to unlink
For t = 1 To C ' setup link loop
ListGet LgCB, Tables, Names, ",", False ' get name form list
DeleteTable Names ' unlink table
Next t ' unlink next table
End If ' if tables to unlink
End Sub
Public Sub LinkTables(FullPath As String, Tables As String)
Dim Names As String ' table names
Dim LgCB As ListCB ' list get structure
Dim C As Integer ' table count
Dim t As Integer ' tables
C = ListCount(Tables, ",") + 1 ' get number of tables
If Tables <> "" Then ' if tables to unlink
For t = 1 To C ' setup link loop
ListGet LgCB, Tables, Names, ",", False ' get name form list
If Not LinkTable(FullPath, Names) Then ' if link to table failed
Tables = "Link to table " & Chr$(34) & Names & Chr$(34) & " in
database " & Chr$(34) & FullPath & Chr$(34) & " failed, make sure you
are connecting to the proper database for this application and if so,
repair and compact both databases."
Err.Raise 40000, , Tables
Exit Sub ' bail out
End If
Next t ' link next table
End If ' if tables to link
End Sub
Public Function TablesExists(Tables As String, NotExist As String) As
Boolean
Dim Names As String ' table names
Dim LgCB As ListCB ' list get structure
Dim C As Integer ' table count
Dim t As Integer ' tables
TablesExists = True
C = ListCount(Tables, ",") + 1 ' get number of tables
If Tables <> "" Then ' if tables to unlink
For t = 1 To C ' setup link loop
ListGet LgCB, Tables, Names, ",", False ' get name form list
If Not TableExists(Names) Then ' if table doesn't exist
TablesExists = False ' signal caller that a table
doesn't exist
If Len(NotExist) = 0 Then ' first non-existing table
NotExist = Names ' start list
Else ' first not non-existing
table
NotExist = NotExist & "," & Names ' add table to list
End If ' first non-existing table
End If ' if table doesn't exist
Next t ' link next table
End If ' if tables to link
End Function
Public Function TableExists(TableName As String) As Boolean
' Check to see if Table (TableName) exists and return answer
Dim DB As Database ' Any Database
Dim TD As TableDef ' Any Table Definition
Set DB = CurrentDb ' Get current database
For Each TD In DB.TableDefs ' Find table
If TD.Name = TableName Then ' If table found
TableExists = True ' Signal caller that table
found
Exit Function ' Back to caller
End If ' If table found
Next TD ' Check next table
Set DB = Nothing
End Function
Public Function IsFormLoaded(FormName As String) As Boolean
' Check to see if Form is loaded and return answer
IsFormLoaded = (SysCmd(acSysCmdGetObjectState, acForm, FormName) <> 0)
End Function
