Author Topic: Add Open File Dialog to VBA  (Read 66746 times)

0 Members and 1 Guest are viewing this topic.

JohnVisioMVP

  • Jr. Member
  • **
  • Posts: 10
Add Open File Dialog to VBA
« on: February 18, 2009, 10:22:41 AM »
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

  • Hero Member
  • *****
  • Posts: 1412
Re: Add Open File Dialog to VBA
« Reply #1 on: February 19, 2009, 07:14:49 AM »
also, that pretty much applies to all of the file io operations.
al

Visio Guy

  • Administrator
  • Hero Member
  • *****
  • Posts: 1736
  • Smart Graphics for Visual People...n' Stuff
    • Visio Guy
Re:Add Open File Dialog to VBA
« Reply #2 on: February 19, 2009, 08:24:44 AM »
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
'// 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
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
For articles, tips and free content, see the Visio Guy Website at http://www.visguy.com
Get my Visio Book! Using Microsoft Visio 2010

AndyW

  • Sr. Member
  • ****
  • Posts: 326
    • PC Mimic Diagram
Re: Add Open File Dialog to VBA
« Reply #3 on: February 19, 2009, 08:26:08 AM »
How about this CComDlg class,  that should work in your VBA

Code
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

...
« Last Edit: February 19, 2009, 10:08:00 AM by Visio Guy »
Live life with an open mind

Visio Guy

  • Administrator
  • Hero Member
  • *****
  • Posts: 1736
  • Smart Graphics for Visual People...n' Stuff
    • Visio Guy
Re: Add Open File Dialog to VBA
« Reply #4 on: May 17, 2010, 10:35:56 AM »
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?
For articles, tips and free content, see the Visio Guy Website at http://www.visguy.com
Get my Visio Book! Using Microsoft Visio 2010

AndyW

  • Sr. Member
  • ****
  • Posts: 326
    • PC Mimic Diagram
Re: Add Open File Dialog to VBA
« Reply #5 on: May 18, 2010, 03:12:44 AM »
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.
Live life with an open mind

aledlund

  • Hero Member
  • *****
  • Posts: 1412
Re: Add Open File Dialog to VBA
« Reply #6 on: May 18, 2010, 04:51:39 PM »
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

  • Hero Member
  • *****
  • Posts: 1154
    • UnmanagedVisio
Re: Add Open File Dialog to VBA
« Reply #7 on: May 22, 2010, 02:45:48 PM »
Please try changing your code as following:

Code
'// 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")
« Last Edit: May 22, 2010, 03:44:11 PM by Nikolay Belyh »