Attribute VB_Name = "basOpenFile" Option Compare Database Option Explicit ' Declarations for Windows Common Dialogs procedures Private Type CLTAPI_OPENFILE strFilter As String ' Filter string intFilterIndex As Long ' Initial Filter to display. strInitialDir As String ' Initial directory for the dialog to open in. strInitialFile As String ' Initial file name to populate the dialog with. strDialogTitle As String ' Dialog title strDefaultExtension As String ' Default extension to append to file if user didn't specify one. lngFlags As Long ' Flags (see constant list) to be used. strFullPathReturned As String ' Full path of file picked. strFileNameReturned As String ' File name of file picked. intFileOffset As Integer ' Offset in full path (strFullPathReturned) where the file name (strFileNameReturned) begins. intFileExtension As Integer ' Offset in full path (strFullPathReturned) where the file extension begins. End Type Const ALLFILES = "All Files" Private Type CLTAPI_WINOPENFILENAME lStructSize As Long hWndOwner As Long hInstance As Long lpstrFilter As String lpstrCustomFilter As String nMaxCustrFilter As Long nFilterIndex 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 lCustrData As Long lpfnHook As Long lpTemplateName As String End Type Const OFN_ALLOWMULTISELECT = &H200 Const OFN_CREATEPROMPT = &H2000 Const OFN_EXPLORER = &H80000 Const OFN_FILEMUSTEXIST = &H1000 Const OFN_HIDEREADONLY = &H4 Const OFN_NOCHANGEDIR = &H8 Const OFN_NODEREFERENCELINKS = &H100000 Const OFN_NONETWORKBUTTON = &H20000 Const OFN_NOREADONLYRETURN = &H8000 Const OFN_NOVALIDATE = &H100 Const OFN_OVERWRITEPROMPT = &H2 Const OFN_PATHMUSTEXIST = &H800 Const OFN_READONLY = &H1 Const OFN_SHOWHELP = &H10 Declare Function CLTAPI_GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" _ (pOpenfilename As CLTAPI_WINOPENFILENAME) _ As Boolean Declare Function CLTAPI_GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" _ (pOpenfilename As CLTAPI_WINOPENFILENAME) _ As Boolean Declare Sub CLTAPI_ChooseColor Lib "msaccess.exe" Alias "#53" _ (ByVal hWnd As Long, rgb As Long) Function GetOpenFile_CLT(strInitialDir As String, strTitle As String) As String ' Comments : Simple file open routine. For additional options, use GetFileOpenEX_CLT() ' Parameters: strInitialDir - path for the initial directory, or blank for the current directory ' strTitle - title for the dialog ' Returns : string path, name and extension of the file selected ' Dim fOK As Boolean Dim typWinOpen As CLTAPI_WINOPENFILENAME Dim typOpenFile As CLTAPI_OPENFILE Dim strFilter As String On Error GoTo PROC_ERR ' Set reasonable defaults for the structure strFilter = CreateFilterString_CLT("All Files (*.*)", "*.*", "Database Files (*.MDB)", "*.MDB") If strInitialDir <> "" Then typOpenFile.strInitialDir = strInitialDir Else typOpenFile.strInitialDir = CurDir() End If If strTitle <> "" Then typOpenFile.strDialogTitle = strTitle End If typOpenFile.strFilter = strFilter typOpenFile.lngFlags = OFN_HIDEREADONLY Or OFN_SHOWHELP ' Convert the CLT structure to a Win structure ConvertCLT2Win typOpenFile, typWinOpen ' Call the Common dialog fOK = CLTAPI_GetOpenFileName(typWinOpen) ' Convert the Win structure back to a CLT structure ConvertWin2CLT typWinOpen, typOpenFile GetOpenFile_CLT = typOpenFile.strFullPathReturned PROC_EXIT: Exit Function PROC_ERR: GetOpenFile_CLT = "" Resume PROC_EXIT End Function Sub ConvertCLT2Win(CLT_Struct As CLTAPI_OPENFILE, Win_Struct As CLTAPI_WINOPENFILENAME) ' Comments : Converts the passed CLTAPI structure to a Windows structure ' Parameters: CLT_Struct - record of type CLTAPI_OPENFILE ' Win_Struct - record of type CLTAPI_WINOPENFILENAME ' Returns : Nothing ' Dim strFile As String * 512 On Error GoTo PROC_ERR Win_Struct.hWndOwner = Application.hWndAccessApp Win_Struct.hInstance = 0 If CLT_Struct.strFilter = "" Then Win_Struct.lpstrFilter = ALLFILES & Chr$(0) & "*.*" & Chr$(0) Else Win_Struct.lpstrFilter = CLT_Struct.strFilter End If Win_Struct.nFilterIndex = CLT_Struct.intFilterIndex Win_Struct.lpstrFile = String(512, 0) Win_Struct.nMaxFile = 511 Win_Struct.lpstrFileTitle = String$(512, 0) Win_Struct.nMaxFileTitle = 511 Win_Struct.lpstrTitle = CLT_Struct.strDialogTitle Win_Struct.lpstrInitialDir = CLT_Struct.strInitialDir Win_Struct.lpstrDefExt = CLT_Struct.strDefaultExtension Win_Struct.Flags = CLT_Struct.lngFlags Win_Struct.lStructSize = Len(Win_Struct) PROC_EXIT: Exit Sub PROC_ERR: Resume PROC_EXIT End Sub Sub ConvertWin2CLT(Win_Struct As CLTAPI_WINOPENFILENAME, CLT_Struct As CLTAPI_OPENFILE) ' Comments : Converts the passed CLTAPI structure to a Windows structure ' Parameters: Win_Struct - record of type CLTAPI_WINOPENFILENAME ' CLT_Struct - record of type CLTAPI_OPENFILE ' Returns : Nothing ' On Error GoTo PROC_ERR CLT_Struct.strFullPathReturned = Left(Win_Struct.lpstrFile, InStr(Win_Struct.lpstrFile, vbNullChar) - 1) CLT_Struct.strFileNameReturned = RemoveNulls_CLT(Win_Struct.lpstrFileTitle) CLT_Struct.intFileOffset = Win_Struct.nFileOffset CLT_Struct.intFileExtension = Win_Struct.nFileExtension PROC_EXIT: Exit Sub PROC_ERR: Resume PROC_EXIT End Sub Function CreateFilterString_CLT(ParamArray varFilt() As Variant) As String ' Comments : Builds a Windows formatted filter string for "file type" ' Parameters: varFilter - parameter array in the format: ' Text, Filter, Text, Filter ... ' Such as: ' "All Files (*.*)", "*.*", "Text Files (*.TXT)", "*.TXT" ' Returns : windows formatted filter string ' Dim strFilter As String Dim intCounter As Integer Dim intParamCount As Integer On Error GoTo PROC_ERR ' Get the count of paramaters passed to the function intParamCount = UBound(varFilt) If (intParamCount <> -1) Then ' Count through each parameter For intCounter = 0 To intParamCount strFilter = strFilter & varFilt(intCounter) & Chr$(0) Next ' Check for an even number of parameters If (intParamCount Mod 2) = 0 Then strFilter = strFilter & "*.*" & Chr$(0) End If End If CreateFilterString_CLT = strFilter PROC_EXIT: Exit Function PROC_ERR: CreateFilterString_CLT = "" Resume PROC_EXIT End Function Function RemoveNulls_CLT(strIn As String) As String ' Comments : Removes terminator from a string ' Parameters: strIn - string to modify ' Return : modified string ' Dim intChr As Integer intChr = InStr(strIn, Chr$(0)) If intChr > 0 Then RemoveNulls_CLT = Left$(strIn, intChr - 1) Else RemoveNulls_CLT = strIn End If End Function