Untested code showing how to use the CommonDialog control in Visual Basic 6.

Basically I just wanted to stop having to hunt for this on CD to type it up from some slightly application-specific code and just come here from now on. Or, worse still, not paste the code in at all and start from scratch. QUELLE HORROR!!!

Just paste this code into a module called "mdlComDlg" or something similar. Poof.

(Updated 1/28/2004)

Option Explicit

'File Selection routine
'Copyright (C) 2003-4 R. Bailey
'
'This library is free software; you can redistribute it and/or
'modify it under the terms of the GNU Lesser General Public
'License as published by the Free Software Foundation; either
'version 2.1 of the License, or (at your option) any later version.
'
'This library is distributed in the hope that it will be useful,
'but WITHOUT ANY WARRANTY; without even the implied warranty of
'MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
'Lesser General Public License for more details.
'
'You should have received a copy of the GNU Lesser General Public
'License along with this library; if not, write to the Free Software
'Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA

Public fso As FileSystemObject

' You must have a CommonDialog on some widget somewhere to pass in.  You apparently
' can't create one at runtime from what I've googled.
'
' Will return "" if no file is selected/user cancels the select/an error occurs
' before a file is selected.
'
' Pass in a collection of extensions to search for with code similar to the following:
'
'    Dim colExts As Collection
'    Set colExts = New Collection
'
'    With colExts
'        .Add ".txt"
'        .Add ".html"
'        .Add ".htm"
'    End With
'
'    Me.RichTextBox1.Text = mdlComDlg.selectFile(Me.CommonDialog1, "C:\", colExts)

Public Function selectFile(cdlgTemp As CommonDialog, _
    Optional strInitDir As String = "", _
    Optional colFileExtensions As Collection, _
    Optional bCreateFileNotOpen As Boolean = False, _
    Optional strRetValIfCancel As String = "") As String
On Error GoTo errHand   ' mainly just going to be capturing
    ' for the cancel button in the common dialog control
    
    Dim strReturn As String
    Dim strFilter As String
    Dim strDot As String
    Dim strPipe As String
    Dim strTemp As String
    Dim varTemp As Variant
    Dim lngFlags As Long
    
    Dim isFileSelected As Boolean   ' b/c of the way cancel errors
        ' are handled, we might branch out of the logic before everything's saved.
        ' If the user got far enough to select a file,
        ' we'll save it out in the error handler on cancel.
        ' This var will tell us if they got that far.
    
    strReturn = ""                  ' no file yet
    isFileSelected = False          ' no file yet
    strFilter = ""
    strPipe = ""
    strDot = ""
    Set fso = New FileSystemObject
    
    With cdlgTemp
        If fso.FolderExists(strInitDir) Then
            .InitDir = strInitDir
        Else
            .InitDir = App.Path
        End If
        
        .FileName = ""
        
        ' set up filters with the extensions (strings) in colFileExtensions.
        If Not colFileExtensions Is Nothing Then
            For Each varTemp In colFileExtensions
                strTemp = CStr(varTemp)
                
                If InStr(strTemp, ".") = 1 Then
                    strDot = ""
                Else
                    strDot = "."
                End If
                
                strFilter = strFilter & _
                    strPipe & _
                    strTemp & " Files (*" & strDot & strTemp & ")" & _
                    "|*" & strDot & strTemp
                
                strPipe = "|"   ' separator after the first extension type.
                
            Next
            
            .Filter = strFilter
        End If
        
        .FilterIndex = 0
        lngFlags = mscomdlg.cdlOFNPathMustExist + _
            mscomdlg.cdlOFNHideReadOnly

        If Not bCreateFileNotOpen Then
            lngFlags = lngFlags + mscomdlg.cdlOFNFileMustExist
        Else
            lngFlags = lngFlags + mscomdlg.cdlOFNOverwritePrompt
        End If
        .Flags = lngFlags
        
        .CancelError = True     ' cancelling causes an error
        
        
        If bCreateFileNotOpen Then
            .ShowSave
        Else
            .ShowOpen
        End If
        
        
        strReturn = .FileName ' If they cancelled,
            ' we'll have "errored out" (cancelerror = true)
        isFileSelected = True   ' If they didn't,
            ' remember that we've gotten this far.
        
        ' insert any code that needs to happen after a file is selected.
    End With
    
    
    selectFile = strReturn

Exit Function
errHand:
    If Not Err.Number = 32755 Then  ' 32755 means that cancel
        ' was selected, and we'll ignore that one
        ' by just dropping out of the sub entirely
        
        MsgBox Err.Number & " :: " & Err.Description
        If Not isFileSelected Then
            strReturn = ""
        End If
    Else    ' else we've got a cancel error
        strReturn = strRetValIfCancel
    End If
    
    selectFile = strReturn
End Function

Labels: ,