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 :
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:
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)|*.acc db", "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:
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
Comment