Linking tables; add filter extension (*.mdb) in a custom open command dialog box

[darksun]

Dear experts,

I got this below code to link to database. I use it as an on click command button to prompt for database to link.

Since it is a code which I didn't create from the beginning (its a modified copy I got from a friend), I would like to know how to add filter extension "*.mdb" (not just *.accdb) in the dialog box.

I've noticed that it must have something to do with the :

• Public Function funOpenCommDlg (...)
• Public Function LinkTableMain()
• sInputFile = funOpenCommDlg("Access Database (*.accdb)|*.accdb", "Select Database to Link ", "", "*.accdb", True)

But I have no idea of how to modify the code. Could you please help me on this?

Many thanks in advance.

This is the code:

Option Compare Database
Option Explicit
 
Private Type OpenFilename
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    lpstrFilter As String
    lpstrCustomFilter As Long
    nMaxCustFilter As Long
    iFilterIndex As Long
    lpstrFile As String
    nMaxFile As Long
    lpstrFileTitle As String
    nMaxFileTitle As Long
    lpstrInitialDir As String
    lpstrTitle As String
    Flags As Long
    nFileOffset As Integer
    nFileExtension As Integer
    lpstrDefExt As String
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As String
End Type
 
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOPENFILENAME As OpenFilename) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOPENFILENAME As OpenFilename) As Long
 
Private Const OFN_READONLY = &H1
Private Const OFN_OVERWRITEPROMPT = &H2
Private Const OFN_HIDEREADONLY = &H4
Private Const OFN_NOCHANGEDIR = &H8
Private Const OFN_SHOWHELP = &H10
Private Const OFN_ENABLEHOOK = &H20
Private Const OFN_ENABLETEMPLATE = &H40
Private Const OFN_ENABLETEMPLATEHANDLE = &H80
Private Const OFN_NOVALIDATE = &H100
Private Const OFN_ALLOWMULTISELECT = &H200
Private Const OFN_EXTENSIONDIFFERENT = &H400
Private Const OFN_PATHMUSTEXIST = &H800
Private Const OFN_FILEMUSTEXIST = &H1000
Private Const OFN_CREATEPROMPT = &H2000
Private Const OFN_SHAREAWARE = &H4000
Private Const OFN_NOREADONLYRETURN = &H8000
Private Const OFN_NOTESTFILECREATE = &H10000
Private Const OFN_NONETWORKBUTTON = &H20000
Private Const OFN_NOLONGNAMES = &H40000                      '  force no long names for 4.x modules
Private Const OFN_EXPLORER = &H80000                         '  new look commdlg
Private Const OFN_NODEREFERENCELINKS = &H100000
Private Const OFN_LONGNAMES = &H200000                       '  force long names for 3.x modules
Private Const OFN_SHAREFALLTHROUGH = 2
Private Const OFN_SHARENOWARN = 1
Private Const OFN_SHAREWARN = 0
 
 
Public Function funOpenCommDlg(ByVal sFilter As String, ByVal sDlgTitle As String, ByVal sDir As String, ByVal sDefExt As String, ByVal bMustExist As Boolean, Optional bMulti As Boolean = False) As String
 
Dim sFullName As String, sFileName As String
Dim lResult As Long, lFlags As Long, i As Integer
Dim uFileDlgData As OpenFilename
 
' Define the filter string, converting all "|" to nulls
sFilter = funSubstitute(sFilter, "|", Chr$(0))
 
' Allocate string space for the returned strings.
sFullName = Space$(25400)
sFileName = Space$(25400)
 
lFlags = OFN_HIDEREADONLY Or OFN_EXPLORER
'Or OFN_NOCHANGEDIR
 
If bMustExist Then lFlags = lFlags Or OFN_FILEMUSTEXIST
If bMulti Then lFlags = lFlags Or OFN_ALLOWMULTISELECT
' Set up the data structure before you call the GetOpenFilename
With uFileDlgData
    .hwndOwner = Application.hWndAccessApp
    .lpstrFilter = sFilter
    .iFilterIndex = 1
    .lpstrFile = sFullName & Chr$(0)
    .nMaxFile = Len(sFullName) + 1
    .lpstrFileTitle = sFileName & Chr$(0)
    .nMaxFileTitle = Len(sFileName) + 1
    .lpstrTitle = sDlgTitle
    .Flags = lFlags
    .lpstrDefExt = sDefExt
    .hInstance = 0
    .lpstrCustomFilter = 0&
    .nMaxCustFilter = 0
    .lpstrInitialDir = sDir
    .nFileOffset = 0
    .nFileExtension = 0
    .lCustData = 0
    .lpfnHook = 0
    .lpTemplateName = ""
    .lStructSize = Len(uFileDlgData)
End With
 
' This will pass the desired data structure to the Windows API,
' which will in turn use it to display the Open Dialog form.
lResult = GetOpenFileName(uFileDlgData)
 
' Return the file selected
If lResult = 0 Then
    funOpenCommDlg = ""
Else
    If bMulti Then
        funOpenCommDlg = uFileDlgData.lpstrFile
    Else
 
        funOpenCommDlg = Left(uFileDlgData.lpstrFile, InStr(uFileDlgData.lpstrFile, vbNullChar) - 1)
    End If
End If
 
End Function
 
Private Function funSubstitute(ByVal sString As String, ByVal sFind As String, ByVal sReplace As String)
 
Dim i As Integer, sTmp As String
 
For i = 1 To Len(sString)
    If Mid(sString, i, 1) = "|" Then
        sTmp = sTmp & Chr$(0)
    Else
        sTmp = sTmp & Mid(sString, i, 1)
    End If
Next
 
funSubstitute = sTmp
 
End Function
 
Function SaveAsCommDlg(ByVal sFilter As String, ByVal sDlgTitle As String, ByVal sDir As String, ByVal sDefExt As String, Optional ByVal sDefName As String = "") As String
 
Dim sFullName As String, sFileName As String
Dim lResult As Long, lFlags As Long, i As Integer
Dim uFileDlgData As OpenFilename
 
sFilter = funSubstitute(sFilter, "|", Chr$(0))
sFullName = sDefName & Space$(254 - Len(sDefName))
sFileName = Space$(254)
 
lFlags = OFN_PATHMUSTEXIST Or OFN_OVERWRITEPROMPT Or OFN_HIDEREADONLY
 
With uFileDlgData
   ' .hwndOwner = FindWindow("XLMAIN", Application.Caption)
    .lpstrFilter = sFilter
    .iFilterIndex = 1
    .lpstrFile = sFullName & Chr$(0)
    .nMaxFile = Len(sFullName) + 1
    .lpstrFileTitle = sFileName & Chr$(0)
    .nMaxFileTitle = Len(sFileName) + 1
    .lpstrTitle = sDlgTitle
    .Flags = lFlags
    .lpstrDefExt = sDefExt
    .hInstance = 0
    .lpstrCustomFilter = 0&
    .nMaxCustFilter = 0
    .lpstrInitialDir = sDir
    .nFileOffset = 0
    .nFileExtension = 0
    .lCustData = 0
    .lpfnHook = 0
    .lpTemplateName = ""
    .lStructSize = Len(uFileDlgData)
End With
 
lResult = GetSaveFileName(uFileDlgData)
 
' Return the file selected
If lResult = 0 Then
    SaveAsCommDlg = ""
Else
    SaveAsCommDlg = Left(uFileDlgData.lpstrFile, InStr(uFileDlgData.lpstrFile, vbNullChar) - 1)
End If
 
End Function
 
Public Function LinkTableMain()
Dim sInputFile As String
Dim tblObj As TableDef, sTableName As String
Dim wsp As Workspace, dbsInput As Database, tdf As TableDef
Dim iReturn As Integer
sInputFile = funOpenCommDlg("Access Database (*.accdb)|*.accdb", "Select Database to Link ", "", "*.accdb", True)
 
If sInputFile <> "" Then
    Set wsp = DBEngine.Workspaces(0)
    ' Return reference to Another.mdb.
    Set dbsInput = wsp.OpenDatabase(sInputFile)
 
    For Each tblObj In dbsInput.TableDefs
        If (tblObj.Attributes And dbSystemObject) = 0 And tblObj.Name <> "Var" And tblObj.Name <> "Repetitive" _
        And Left((tblObj.Name), 4) <> "MSys" _
        Then
            sTableName = tblObj.Name
 
            iReturn = SysCmd(acSysCmdSetStatus, "Linking Table " & sTableName & ", please wait...")
            'Remove existng link
            On Error Resume Next
            CurrentDb.TableDefs.Delete sTableName
            'On Error GoTo 0
                'Remove data for the same date
            Set tdf = CurrentDb.CreateTableDef(sTableName)
 
            tdf.Connect = ";Database=" & sInputFile
            tdf.SourceTableName = sTableName
            CurrentDb.TableDefs.Append tdf
 
        End If
    Next
 
    dbsInput.Close
    Set dbsInput = Nothing
    Set wsp = Nothing
    Set tdf = Nothing
    iReturn = SysCmd(acSysCmdClearStatus)
 
ElseIf sInputFile = "" Then Exit Function
End If
 On Error GoTo 0
 
Set tblObj = Nothing
 
End Function
 

[zmbd]

Go to the bottom of this page
Click on the Microsoft Access / VBA Insights Sitemap
Read article 29
Should put you on the "right track"

[darksun]

@zmbd
Nope it doesn't. Sorry...
The title of article 29 is:
"recover deleted records in MS access database" which has nothing to do with linked database...

[zmbd]

You did not click on the "Microsoft Access / VBA Insights Sitemap" link at the bottom of this page.

Instead it appears that you may have have clicked on:
" Microsoft Access / VBA Answers Sitemap"

If you will do so again, you'll find that the "Recover Deleted..." is (as of 07:04CST) Entry #30 and more than likely has dropped down the listing a tad.

However if you had clicked on the Microsoft Access / VBA Insights Sitemap link at the bottom of this thread page you would have been taken the list where would have seen:

I'll provide the link here: 29. Select a File or Folder using the FileDialog Object

[darksun]

Got it. I modified some lines and found it working well. Thanks.

@zmbd

[zmbd]

I'm glad that worked!
NeoPa did a bang-up-job (IMHO) with one of the clearest, cleanest codes and explantion that I've seen for dialogs.
I've seen other codes that just appear to go on and on and on and no real explanation about what is going on and on and on.

TTFN