Attribute VB_Name = "basCommDlg"
'*******************************************************************************
' Project   : Generic
'             
' Module    : basCommDlg
' DateTime  : 9/22/2004 15:19
' Source    : Access Developer's Handbook
' Edited By : Bill Mosca
' Purpose   : This module will open a common dialog box without using an ActiveX dialog
'           control on a form.
'*******************************************************************************

Option Compare Database
Option Explicit
Type adh_accOfficeGetFileNameInfo
    hwndOwner As Long
    strAppName As String * 255
    strDlgTitle As String * 255
    strOpenTitle As String * 255
    strFile As String * 4096
    strInitialDir As String * 255
    strFilter As String * 255
    lngFilterIndex As Long
    lngView As Long
    lngFlags As Long
End Type

Public Enum adhMode
    SAVE_AS = 0
    OPEN_ = -1
End Enum

Declare Function adh_accOfficeGetFileName Lib "msaccess.exe" Alias "#56" (gfni As adh_accOfficeGetFileNameInfo, ByVal fOpen As Integer) As Long

Public Function adhOfficeGetFileName(gfni As adh_accOfficeGetFileNameInfo, ByVal fOpen As Integer) As Long
    Dim lng As Long
    With gfni
        .strAppName = RTrim$(.strAppName) & vbNullChar
        .strDlgTitle = RTrim$(.strDlgTitle) & vbNullChar
        .strOpenTitle = RTrim$(.strOpenTitle) & vbNullChar
        .strFile = RTrim$(.strFile) & vbNullChar
        .strInitialDir = RTrim$(.strInitialDir) & vbNullChar
        .strFilter = RTrim$(.strFilter) & vbNullChar
        SysCmd acSysCmdClearHelpTopic
        lng = adh_accOfficeGetFileName(gfni, fOpen)
        .strAppName = RTrim$(adhTrimNull(.strAppName))
        .strDlgTitle = RTrim$(adhTrimNull(.strDlgTitle))
        .strOpenTitle = RTrim$(adhTrimNull(.strOpenTitle))
        .strFile = RTrim$(adhTrimNull(.strFile))
        .strInitialDir = RTrim$(adhTrimNull(.strInitialDir))
        .strFilter = RTrim$(adhTrimNull(.strFilter))
    End With
    adhOfficeGetFileName = lng
    
End Function

Public Function adhTrimNull(strVal As String) As String
    Dim intPos As Integer
    intPos = InStr(strVal, vbNullChar)
    If intPos > 0 Then
        adhTrimNull = Left$(strVal, intPos - 1)
    Else
        adhTrimNull = strVal
    End If
    
End Function

Public Function OpenCommDlgDir(strDlgTitle As String, strDir As String, mode As Integer)
'Purpose  : Opens commom dialog box for a directory
    Dim gfni As adh_accOfficeGetFileNameInfo
    
    On Error GoTo err_OpenCommDlgDir
    
    With gfni
        .lngFlags = &H20
        .strDlgTitle = strDlgTitle & ""
        .strOpenTitle = "&OK" & ""
        .strInitialDir = strDir & ""
    End With
    
    OpenCommDlgDir = ""
    'mode : -1 for Open; 0 for Save
    If adhOfficeGetFileName(gfni, mode) = 0 Then
        OpenCommDlgDir = Trim(gfni.strFile)
    End If

exit_OpenCommDlgDir:
    Exit Function
    
err_OpenCommDlgDir:
    MsgBox Err.Description & Chr(13) & Chr(10) & " ErrorNum:" & Str(Err), 48
    Resume exit_OpenCommDlgDir
    
End Function

Public Function OpenCommDlg(strDlgTitle As String, strFile As String, mode As Integer, defPath As String) As String
'Purpose  : Allow user to choose name of file to open/save
'           Returns filename w/ path
'           Example of call:
'               sFile = OpenCommDlg("Import Files", "clink*", -1, conFilePath & sSubFolder)
'           parameters:
'               1st = Box Title
'               2nd = Filename
'               3rd = open(-1) or SaveAs(0)
'               4th = FilePath with subfolder if necessary.
    Dim stdir As String, dbFilename As String
    Dim gfni As adh_accOfficeGetFileNameInfo

    On Error GoTo err_OpenCommDlg


    'Make sure not to pass in Null values.
    With gfni
        .strDlgTitle = strDlgTitle & ""
        .strFile = strFile & ""
        .strInitialDir = defPath & ""
        .strFilter = "All Files(*.*)" & ""
        .strOpenTitle = "&OK" & ""
    End With
    
    'mode : -1 for Open; 0 for Save
    If adhOfficeGetFileName(gfni, mode) = 0 Then
        dbFilename = Trim(gfni.strFile)
    End If

    OpenCommDlg = dbFilename
    
exit_OpenCommDlg:
    Exit Function
    
err_OpenCommDlg:
    MsgBox Err.Description & Chr(13) & Chr(10) & " ErrorNum:" & Str(Err), 48
    Resume exit_OpenCommDlg
    
End Function