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
also, that pretty much applies to all of the file io operations.
al
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"
'// 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:
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
How about this CComDlg class, that should work in your VBA
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
...
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?
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.
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
Please try changing your code as following:
'// 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 (http://gpgonaccess.blogspot.com/2010/03/work-in-progress-and-64-bit-vba.html).
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")