Getting filenames in other applications than Excel

 2011-07-02    Files & Folders    0    380

In Excel we find the really nice functionality Application.GetOpenFilename and Application.GetSaveAsFilename that makes it really easy to ask the user for one or more filenames when opening or saving files. In other Office-applications this is sometimes not equally easy to achieve. The good news is that you can borrow this nice functionality from Excel in the other applications. Below you will find two functions that can be used outside Excel that will replicate this functionality for retrieving filenames. The functions use basically the same arguments as the Excel functions. Look them up in the built in VBA Help to get details about how to use e.g. the strFileFilter argument.

Function GetOpenFilename(strFileFilter As String, Optional strCaption As String = vbNullString, _
     Optional blnMulti As Boolean = False, Optional strInitialFolder As String = vbNullString) As Variant
 Dim objXL As Object
     GetOpenFilename = False
     If Len(strInitialFolder) >= 3 Then
         On Error Resume Next
         ChDrive Left(strInitialFolder, 1)
         ChDir strInitialFolder
         On Error GoTo 0
     End If
     On Error Resume Next
     Set objXL = CreateObject("Excel.Application")
     On Error GoTo 0
     If Not objXL Is Nothing Then
         With objXL
             GetOpenFilename = .GetOpenFilename(strFileFilter, 1, strCaption, , blnMulti)
             .Quit
         End With
         Set objXL = Nothing
     End If
 End Function
Function GetSaveAsFilename(strInitialFileName As String, strFileFilter As String, _
     Optional strCaption As String = vbNullString, Optional strInitialFolder As String = vbNullString) As Variant
Dim objXL As Object
    GetSaveAsFilename = False
    If Len(strInitialFolder) >= 3 Then
        On Error Resume Next
        ChDrive Left(strInitialFolder, 1)
        ChDir strInitialFolder
        On Error GoTo 0
    End If
    On Error Resume Next
    Set objXL = CreateObject("Excel.Application")
    On Error GoTo 0
    If Not objXL Is Nothing Then
        With objXL
            GetSaveAsFilename = .GetSaveAsFilename(strInitialFileName, strFileFilter, 1, strCaption)
            .Quit
        End With
        Set objXL = Nothing
    End If
End Function
Sub UsageExamples()
Dim varItems As Variant, i As Long
    ' how to retrieve a single filename for opening:
    varItems = GetOpenFilename("Excel Files (*.xl*),*.xl*,All Files (*.*),*.*", "Select Multiple Files", True)
    If len(varItems) >= 6 Then ' one file selected
        Debug.Print varItems
    End If

    ' how to retrieve multiple filenames for opening:
    varItems = GetOpenFilename("Excel Files (*.xl*),*.xl*,All Files (*.*),*.*", "Select Multiple Files", True)
    If IsArray(varItems) Then ' one or more files selected
        For i = LBound(varItems) To UBound(varItems)
            Debug.Print i, varItems(i)
        Next i
    End If

    ' how to retrieve a single filename for saving:
    varItems = GetSaveAsFilename("InitialWorkbook.xlsx", "Excel Files (*.xlsx),*.xlsx,All Files (*.*),*.*")
    If Len(varItems) >= 6 Then ' one filename returned
        Debug.Print varItems
    End If
End Sub