This libray is old (2.0 I think) anyway it still compiles under A97,
basically, you call OpenDialog to get the full path to your tables
database and pass it with a comma delinited string of the tables
within that db you want linked to LinkTables(FullPath As String,
Tables As String)
have fun
Nothing fancy here, just copy this into a module and compile. This
libray makes reference to my error hander libary which I'm not posting
so correct anyway you want.
Option Compare Database
Option Explicit
Type ParsePathCB ' ParsePath control block
sDrive As String ' Drive letter with
terminator (:)
sDirName As String ' Directory path name with
terminator(s) (\)
sFilName As String ' File name without
terminator(s) (.)
sExt 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 Type OPENFILENAME
lStructSize As Long ' Specifies the length, in
bytes, of the structure
hwndOwner As Long ' Identifies the window
that owns the dialog box. This member can be any valid window handle,
or NULL if the dialog box has no owner
hInstance As Long ' Identifies a data block
that contains a dialog box template specified by the lpstrTemplateName
member. This member is used only if the Flags member specifies the
OFN_ENABLETEMPLATE flag; otherwise, this member is ignored
lpstrFilter As String ' Points to a buffer
containing pairs of null-terminated filter strings. The first string
in each pair describes a filter (for example, Text Files), the second
specifies the filter pattern (for example, *.TXT). Multiple filters
can be specified for a single item by separating the filter-pattern
strings with a semicolon (for example, *.TXT;*.DOC;*.BAK). The last
string in the buffer must be terminated by two NULL characters. If
this parameter is NULL, the dialog box will not display any filters.
The filter strings are assumed to be in the proper order the operating
system does not change the order
lpstrCustomFilter As String ' Points to a buffer
containing a pair of user-defined filter strings. The first string
describes the filter, and the second specifies the filter pattern (for
example WinWord, *.docnn). The buffer is terminated by two NULL
characters. The operating system copies the strings to the buffer when
the user closes the dialog box. The system uses the strings to
initialize the user-defined file filter the next time the dialog box
is created. If this parameter is NULL, the dialog box lists but does
not save user-defined filter strings
nMaxCustFilter As Long ' Specifies the size, in
characters, of the buffer identified by the lpstrCustomFilter member.
This buffer should be at least 40 characters long. This parameter is
ignored if the lpstrCustomFilter member is NULL or points to a NULL
string
nFilterIndex As Long ' Specifies an index into
the buffer pointed to by the lpstrFilter member. The operating system
uses the index value to obtain a pair of strings to use as the initial
filter description and filter pattern for the dialog box. The first
pair of strings has an index value of 1. When the user closes the
dialog box, the system copies the index of the selected filter strings
into this location. If the nFilterIndex member is 0, the custom filter
is used. If the nFilterIndex member is 0 and the lpstrCustomFilter
member is NULL, the system uses the first filter in the buffer
identified by the lpstrFilter member. If all three members are 0 or
NULL, the system does not use any filters and does not show any files
in the file list control of the dialog box
lpstrFile As String ' Points to a buffer that
contains a filename used to initialize the File Name edit control. The
first character of this buffer must be NULL if initialization is not
necessary. When the GetOpenFileName or GetSaveFileName function
returns, this buffer contains the drive designator, path, filename,
and extension of the selected file. If the buffer is too small, the
dialog box procedure copies the required size into this member
nMaxFile As Long ' Specifies the size, in
characters, of the buffer pointed to by the lpstrFile member. The
GetOpenFileName and GetSaveFileName functions return FALSE if the
buffer is too small to contain the file information. The buffer should
be at least 256 characters long. This member is ignored if the
lpstrFile member is NULL
lpstrFileTitle As String ' Points to a buffer that
receives the title of the selected file. For Windows versions 3.0 and
3.1, this buffer receives the filename and extension without path
information. This application should use this string to display the
file title. If this member is NULL, the function does not copy the
file title
nMaxFileTitle As Long ' Specifies the maximum
length of the string that can be copied into the lpstrFileTitle
buffer. This member is ignored if lpstrFileTitle is NULL
lpstrInitialDir As String ' Points to a string that
specifies the initial file directory. If this member is NULL, the
system uses the current directory as the initial directory
lpstrTitle As String ' Points to a string to be
placed in the title bar of the dialog box. If this member is NULL, the
system uses the default title (that is, Save As or Open)
Flags As Long ' Specifies the dialog box
creation flags. This member may be a combination of the OFN_ values
nFileOffset As Integer ' Specifies a zero-based
offset from the beginning of the path to the filename in the string to
which the lpstrFile member points. For example, if lpstrFile points to
the following string, c:\dir1\dir2\file.ext, this member contains the
value 13
nFileExtension As Integer ' Specifies a zero-based
offset from the beginning of the path to the filename extension in the
string pointed to by the lpstrFile member. For example, if lpstrFile
points to the following string, c:\dir1\dir2\file.ext, this member
contains the value 18. If the user did not type an extension and
lpstrDefExt is NULL, this member specifies an offset to the
terminating null character. If the user typed. as the last character
in the filename, this member specifies 0
lpstrDefExt As String ' Points to a buffer that
contains the default extension. The GetOpenFileName and
GetSaveFileName functions append this extension to the filename if the
user fails to type an extension. This string can be any length, but
only the first three characters are appended. The string should not
contain a period (.). If this member is NULL and the user fails to
type an extension, no extension is appended
lCustData As Long ' Specifies
application-defined data that the operating system passes to the hook
function identified by the lpfnHook member. The system passes the data
in the lParam parameter of the WM_INITDIALOG message
lpfnHook As Long ' Points to a hook
function that processes messages intended for the dialog box. An
application must specify the OFN_ENABLEHOOK flag in the Flags member
to enable the function; otherwise, the operating system ignores this
structure member. The hook function should return FALSE to pass a
message to the standard dialog box procedure, or TRUE to discard the
message
lpTemplateName As String ' Points to a
null-terminated string that names the dialog box template resource to
be substituted for the standard dialog box template. An application
can use the MAKEINTRESOURCE macro for numbered dialog box resources.
This member is used only if the Flags member specifies the
OFN_ENABLETEMPLATE flag; otherwise, this member is ignored
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
Public Function OpenDialog(cf As Form, Filter As String, Title As
String, InitDir As String) As String
' IniDir = "C:\My Documents"
' Title = "Find and Select File"
' Filter = "Microsoft Access Databases (*.mdb)|*.mdb|Microsoft Access
Databases (*.mde)|(*.mde)|"
' FullPath = OpenDialog(Me, Filter, Title, IntDir)
Dim ofn As OPENFILENAME ' open file name structure
Dim t As Long ' terminator
On Error GoTo ErrorRoute
ofn.lStructSize = Len(ofn) ' set structure length
ofn.hwndOwner = cf.hWnd ' set handle of owner form
Do ' setup loop for filter
terminator
t = InStr(t + 1, Filter, "|") ' find filter terminator,
if found, replace with null
If t <> 0 Then Mid$(Filter, t, 1) = Chr$(0)
Loop Until t = 0 ' loop until all
terminators are replaced
ofn.lpstrFilter = Filter ' set file filter
ofn.lpstrFile = Space$(254) ' initialize return file
name buffer (no starting file name)
ofn.nMaxFile = 255 ' set size of lpstrFile
buffer
ofn.lpstrFileTitle = Space$(254) ' initialize return
selected file title buffer
ofn.nMaxFileTitle = 255 ' set size of
lpstrFileTitle buffer
ofn.lpstrInitialDir = InitDir ' set initial directory
ofn.lpstrTitle = Title ' set dialog title
' Set dialog flags
ofn.Flags = OFN_HIDEREADONLY Or OFN_FILEMUSTEXIST
t = api_GetOpenFileName(ofn) ' fire off dialog
If (t) Then ' if file selected, return
file name
OpenDialog = Left$(ofn.lpstrFile, Len(Trim$(ofn.lpstrFile)) - 1)
Else ' if file not selected
OpenDialog = "" ' return no file name
End If ' if file selected
Exit Function
ErrorRoute: ' error routing
ErrorRouter.ErrorHandler cf.Name & ".OpenDialog"
End Function
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
