Add Open File Dialog to VBA

[JohnVisioMVP]

Currently there is no easy way to use a File Open Dialog witout hacking in to one of the other Office apps that have that feature.

John... Visio mVP

[aledlund]

also, that pretty much applies to all of the file io operations.
al

[Visio Guy]

While I agree that this should be part of Visio's VBA,

I'll post a fairly simple work-around for those who are stuck.

There is some API code to get 'hold of the windows common dialogs.

I use, for example a module called "OpenExcelFile"

Code Select Expand

'// Module: OpenExcelFile
'//
'// This is code that uses the Windows API to invoke the Open File
'// common dialog. It is used by users to choose an Excel file that
'// contains organizational data.

Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _
  "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long

Private Type OPENFILENAME
  lStructSize As Long
  hwndOwner As Long
  hInstance As Long
  lpstrFilter As String
  lpstrCustomFilter As String
  nMaxCustFilter 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
  lCustData As Long
  lpfnHook As Long
  lpTemplateName As String
End Type

Public Sub FindExcelFile(ByRef filePath As String, _
                         ByRef cancelled As Boolean)

    Dim OpenFile As OPENFILENAME
    Dim lReturn As Long
    Dim sFilter As String
   
    On Error GoTo errTrap
   
    OpenFile.lStructSize = Len(OpenFile)

    '// Sample filter:
    '// "Text Files (*.txt)" & Chr$(0) & "*.sky" & Chr$(0) & "All Files (*.*)" & Chr$(0) & "*.*"
    sFilter = "Excel Files (*.xl*)" & Chr(0) & "*.xl*"
   
    OpenFile.lpstrFilter = sFilter
    OpenFile.nFilterIndex = 1
    OpenFile.lpstrFile = String(257, 0)
    OpenFile.nMaxFile = Len(OpenFile.lpstrFile) - 1
    OpenFile.lpstrFileTitle = OpenFile.lpstrFile
    OpenFile.nMaxFileTitle = OpenFile.nMaxFile
    OpenFile.lpstrInitialDir = ThisDocument.path
   
    OpenFile.lpstrTitle = "Find Excel Data Source"
    OpenFile.flags = 0
    lReturn = GetOpenFileName(OpenFile)
   
    If lReturn = 0 Then
       cancelled = True
       filePath = vbNullString
    Else
      cancelled = False
      filePath = Trim(OpenFile.lpstrFile)
      filePath = Replace(filePath, Chr(0), vbNullString)
    End If

    Exit Sub
   
errTrap:
    Exit Sub
    Resume

End Sub



I call it using this little sub-routine:

Code Select Expand

Private Function m_getExcelFilePath() As String

  Dim pathExcel As String
  Dim bCancelled As Boolean
 
  Call OpenExcelFile.FindExcelFile(pathExcel, bCancelled)
 
  If bCancelled Then
    m_getExcelFilePath = vbNullString
  Else
    m_getExcelFilePath = pathExcel
  End If

End Function

[AndyW]

How about this CComDlg class,  that should work in your VBA

Code Select Expand


Option Explicit

DefStr S
DefLng N
DefBool B
DefVar V

' OFN constants.
Const OFN_ALLOWMULTISELECT   As Long = &H200
Const OFN_CREATEPROMPT       As Long = &H2000
Const OFN_EXPLORER           As Long = &H80000
Const OFN_EXTENSIONDIFFERENT As Long = &H400
Const OFN_FILEMUSTEXIST      As Long = &H1000
Const OFN_HIDEREADONLY       As Long = &H4
Const OFN_LONGNAMES          As Long = &H200000
Const OFN_NOCHANGEDIR        As Long = &H8
Const OFN_NODEREFERENCELINKS As Long = &H100000
Const OFN_OVERWRITEPROMPT    As Long = &H2
Const OFN_PATHMUSTEXIST      As Long = &H800
Const OFN_READONLY           As Long = &H1

' The maximum length of a single file path.
Const MAX_PATH As Long = 260
' This MAX_BUFFER value allows you to select approx.
' 500 files with an average length of 25 characters.
' Change this value as needed.
Const MAX_BUFFER As Long = 50 * MAX_PATH
' String constants:
Const sBackSlash As String = "\"
Const sPipe As String = "|"

' API functions to use the Windows common dialog boxes.
Private Declare Function GetOpenFileName _
 Lib "comdlg32.dll" Alias "GetOpenFileNameA" _
 (pOpenfilename As OPENFILENAME) As Long
Private Declare Function GetSaveFileName _
 Lib "comdlg32.dll" Alias "GetSaveFileNameA" _
 (pOpenfilename As OPENFILENAME) As Long
Private Declare Function GetActiveWindow _
 Lib "user32" () As Long

' Type declaration, used by GetOpenFileName and
' GetSaveFileName.
Private Type OPENFILENAME
 lStructSize       As Long
 hwndOwner         As Long
 hInstance         As Long
 lpstrFilter       As String
 lpstrCustomFilter As String
 nMaxCustFilter    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
 lCustData         As Long
 lpfnHook          As Long
 lpTemplateName    As String  ' Can also be a Long.
End Type

' Private variables.
Private OFN As OPENFILENAME
Private colFileTitles As New Collection
Private colFileNames As New Collection
Private sFullName As String
Private sFileTitle As String
Private sPath As String
Private sExtension As String

' Public enumeration variable.
Public Enum XFlags
 PathMustExist = OFN_PATHMUSTEXIST
 FileMustExist = OFN_FILEMUSTEXIST
 PromptToCreateFile = OFN_CREATEPROMPT
End Enum

Property Let AllowMultiSelect(bFlag As Boolean)
 SetFlag OFN_ALLOWMULTISELECT, bFlag
End Property

Property Let DialogTitle(sCaption As String)
 OFN.lpstrTitle = sCaption
End Property

Property Let Filter(vFilter)
 If IsArray(vFilter) Then _
   vFilter = Join(vFilter, vbNullChar)
 OFN.lpstrFilter = _
   Replace(vFilter, sPipe, vbNullChar) & vbNullChar
End Property

Property Get Filter()
 With OFN
   If .nFilterIndex Then
     Dim sTemp()
     sTemp = Split(.lpstrFilter, vbNullChar)
     Filter = sTemp(.nFilterIndex * 2 - 2) & sPipe & _
       sTemp(.nFilterIndex * 2 - 1)
   End If
 End With
End Property

Property Let FilterIndex(nIndex)
 OFN.nFilterIndex = nIndex
End Property

Property Get FilterIndex() As Long
 FilterIndex = OFN.nFilterIndex
End Property

Property Let RestoreCurDir(bFlag As Boolean)
 SetFlag OFN_NOCHANGEDIR, bFlag
End Property

Property Let ExistFlags(nFlags As XFlags)
 OFN.flags = OFN.flags Or nFlags
End Property

Property Let CheckBoxVisible(bFlag As Boolean)
 SetFlag OFN_HIDEREADONLY, Not bFlag
End Property

Property Let CheckBoxSelected(bFlag As Boolean)
 SetFlag OFN_READONLY, bFlag
End Property

Property Get CheckBoxSelected() As Boolean
 CheckBoxSelected = OFN.flags And OFN_READONLY
End Property

Property Let FileName(sFileName As String)
 If Len(sFileName) <= MAX_PATH Then _
   OFN.lpstrFile = sFileName
End Property

Property Get FileName() As String
 FileName = sFullName
End Property

Property Get FileNames() As Collection
 Set FileNames = colFileNames
End Property

Property Get FileTitle() As String
 FileTitle = sFileTitle
End Property

Property Get FileTitles() As Collection
 Set FileTitles = colFileTitles
End Property

Property Let Directory(sInitDir)
 OFN.lpstrInitialDir = sInitDir
End Property

Property Get Directory() As String
 Directory = sPath
End Property

Property Let Extension(sDefExt As String)
 OFN.lpstrDefExt = LCase$(Left$( _
   Replace(sDefExt, ".", vbNullString), 3))
End Property

Property Get Extension() As String
 Extension = sExtension
End Property

Function ShowOpen() As Boolean
 ShowOpen = show(True)
End Function

Function ShowSave() As Boolean
 ' Set or clear appropriate flags for Save As dialog.
 SetFlag OFN_ALLOWMULTISELECT, False
 SetFlag OFN_PATHMUSTEXIST, True
 SetFlag OFN_OVERWRITEPROMPT, True
 ShowSave = show(False)
End Function

Private Function show(bOpen As Boolean)
 With OFN
   .lStructSize = Len(OFN)
   ' Could be zero if no owner is required.
   .hwndOwner = GetActiveWindow
   ' If the RO checkbox must be checked, we should also
   ' display it.
   If .flags And OFN_READONLY Then _
     SetFlag OFN_HIDEREADONLY, False
   ' Create large buffer if multiple file selection
   ' is allowed.
   .nMaxFile = IIf(.flags And OFN_ALLOWMULTISELECT, _
     MAX_BUFFER + 1, MAX_PATH + 1)
   .nMaxFileTitle = MAX_PATH + 1
   ' Initialize the buffers.
   .lpstrFile = .lpstrFile & String$( _
     .nMaxFile - 1 - Len(.lpstrFile), 0)
   .lpstrFileTitle = String$(.nMaxFileTitle - 1, 0)

   ' Display the appropriate dialog.
   If bOpen Then
     show = GetOpenFileName(OFN)
   Else
     show = GetSaveFileName(OFN)
   End If

   If show Then
     ' Remove trailing null characters.
     Dim nDoubleNullPos
     nDoubleNullPos = InStr(.lpstrFile & vbNullChar, _
                             String$(2, 0))
     If nDoubleNullPos Then
       ' Get the file name including the path name.
       sFullName = Left$(.lpstrFile, nDoubleNullPos - 1)
       ' Get the file name without the path name.
       sFileTitle = Left$(.lpstrFileTitle, _
         InStr(.lpstrFileTitle, vbNullChar) - 1)
       ' Get the path name.
       sPath = Left$(sFullName, .nFileOffset - 1)
       ' Get the extension.
       If .nFileExtension Then
         sExtension = Mid$(sFullName, .nFileExtension + 1)
       End If
       ' If sFileTitle is a string,
       ' we have a single selection.
       If Len(sFileTitle) Then
         ' Add to the collections.
         colFileTitles.add _
           Mid$(sFullName, .nFileOffset + 1)
         colFileNames.add sFullName
       Else  ' Tear multiple selection apart.
         Dim sTemp(), nCount
         sTemp = Split(sFullName, vbNullChar)
         ' If array contains no elements,
         ' UBound returns -1.
         If UBound(sTemp) > LBound(sTemp) Then
           ' We have more than one array element!
           ' Remove backslash if sPath is the root folder.
           If Len(sPath) = 3 Then _
             sPath = Left$(sPath, 2)
           ' Loop through the array, and create the
           ' collections; skip the first element
           ' (containing the path name), so start the
           ' counter at 1, not at 0.
           For nCount = 1 To UBound(sTemp)
             colFileTitles.add sTemp(nCount)
             ' If the string already contains a backslash,
             ' the user must have selected a shortcut
             ' file, so we don't add the path.
             colFileNames.add IIf(InStr(sTemp(nCount), _
               sBackSlash), sTemp(nCount), _
               sPath & sBackSlash & sTemp(nCount))
           Next
           ' Clear this variable.
           sFullName = vbNullString
         End If
       End If
       ' Add backslash if sPath is the root folder.
       If Len(sPath) = 2 Then _
         sPath = sPath & sBackSlash
     End If
   End If
 End With
End Function

Private Sub SetFlag(nValue, bTrue As Boolean)
 ' Wrapper routine to set or clear bit flags.
 With OFN
   If bTrue Then
     .flags = .flags Or nValue
   Else
     .flags = .flags And Not nValue
   End If
 End With
End Sub

Private Sub Class_Initialize()
 ' This routine runs when the object is created.
 OFN.flags = OFN.flags Or OFN_EXPLORER Or _
             OFN_LONGNAMES Or OFN_HIDEREADONLY
End Sub



Use as,

   With New CComDlg
           
       .DialogTitle = "Open"
       .RestoreCurDir = True
       .FileName = vbNullString
       .Extension = "jpg"
       .Filter = "Image Files (*.jpg;*.png;*.gif;*.bmp)|*.jpg;*.png;*.gif;*.bmp"
       .ExistFlags = PathMustExist
       .Directory = strResourcesPath
           
       If .ShowOpen Then
   
           strFileName = .FileName

...

[Visio Guy]

None of these methods are working in 64-bit Windows 7 with 64-bit Visio. Has anybody had any success creating an open file dialog in VBA in the 64-bit world?

[AndyW]

I think the problem is comdlg32 is 32 bit so isn't going to work with 64 bit apps, I did find something saying about running apps under WOW on 64 bit windows, but presumably thats for 32 bit apps. So looks like that won't work for 64 bit Visio. This is what comes of VB.Net, with no VB6 future, VBA doesn't seem to move on either.

[aledlund]

this still works

Public Sub openDoc()
    Dim visApp As Visio.Application
    Set visApp = Application
    Dim visDoc As Visio.Document
    visApp.Application.DoCmd (VisUICmds.visCmdFileOpen)
    Set docObj = visApp.ActiveDocument
End Sub

al

[Nikolay]

Please try changing your code as following:

Code Select Expand


'// Module: OpenExcelFile
'//
'// This is code that uses the Windows API to invoke the Open File
'// common dialog. It is used by users to choose an Excel file that
'// contains organizational data.

Private Declare PtrSafe Function GetOpenFileName Lib "comdlg32.dll" _
   Alias "GetOpenFileNameA" (OFN As OPENFILENAME) As Boolean

Private Type OPENFILENAME
 lStructSize As Long
 hwndOwner As LongPtr
 hInstance As LongPtr
 lpstrFilter As String
 lpstrCustomFilter As String
 nMaxCustFilter 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
 lCustData As Long
 lpfnHook As LongPtr
 lpTemplateName As String
End Type

Public Sub FindExcelFile(ByRef filePath As String, _
                        ByRef cancelled As Boolean)

   Dim OpenFile As OPENFILENAME
   Dim lReturn As Long
   Dim sFilter As String
   
   ' On Error GoTo errTrap
   
   OpenFile.lStructSize = LenB(OpenFile)

   '// Sample filter:
   '// "Text Files (*.txt)" & Chr$(0) & "*.sky" & Chr$(0) & "All Files (*.*)" & Chr$(0) & "*.*"
   sFilter = "Excel Files (*.xl*)" & Chr(0) & "*.xl*"
   
   OpenFile.lpstrFilter = sFilter
   OpenFile.nFilterIndex = 1
   OpenFile.lpstrFile = String(257, 0)
   OpenFile.nMaxFile = Len(OpenFile.lpstrFile) - 1
   OpenFile.lpstrFileTitle = OpenFile.lpstrFile
   OpenFile.nMaxFileTitle = OpenFile.nMaxFile
   OpenFile.lpstrInitialDir = ThisDocument.Path
   
   OpenFile.lpstrTitle = "Find Excel Data Source"
   OpenFile.flags = 0
   lReturn = GetOpenFileName(OpenFile)
   
   If lReturn = 0 Then
      cancelled = True
      filePath = vbNullString
   Else
     cancelled = False
     filePath = Trim(OpenFile.lpstrFile)
     filePath = Replace(filePath, Chr(0), vbNullString)
   End If

   Exit Sub
   
errTrap:
   Exit Sub
   Resume

End Sub


Works for me. The idea was taken from here.
The ddifferences are hilighted below. The first issue with the code was that "OPENFILENAME" structure was declared incorrectly for 64-bit, since on 64-bit windows pointers are 64-bit as well, but the code declared them as "Long", i.e. as 32-bit; the second problem was that the size of the OPENFILENAME structure was calcuated incorrectly for 64-bit windows - "LenB" is to be used instead of "Len" (most probably because of structure alignment assumed by "Len")