In VBA 7.1, Autocad 2014 there is no way to open file selection window.
Can anyone advose how to:
CommonDialog1.ShowOpen
Thanks,
Jure
64-bit AutoCAD 2014's re-introduce VBA as in-process environment does not mean previous VBA progams (all are 32-bit version prior to Acad2014, of course) would be run automatically.
If the existiing VBA application heavily depends on controls that only available in 32-bit version, then one must find suiatble replacement. One of the major reasons people use VBA in AutoCAD in the past was the its advantage of UI over AutoLISP. So, many existing VBA apps rely on rich UI designs to run and the UI components (mostly, ActiveX controls) used in all AutoCAD VBA so far (until AutoCAD 2014's 64-bit VBA) are all 32-bit, which CANNOT be used in 64-bit VBA.
In the csse of CommandDialog, no it cannot be used in VBA7.1, if it is 64-bit. Please note the keyword: 64-bit. With AutoCAD 2014, VBA7.1 can be either 32-bit and 64-bit, depending on AutoCAD. The problem you run into must be because of you using 64-bit AutoCAD (who still does not?).
As workaround, you have to remove the CommandDialog and use direct Windows API call to get open/save file dialog box. As aforementioned, if your VBA also use other 32-bit ActiveX controls that do not have 64-biy equivalent (very likely), you would have more difficulties to convert your existing VBA code into 64-bit VBA7. You may find out it is not worth the troubles to move the VBA code to 64-bit VBA7.
Norman Yuan
Try this (collected from various sources biut it WORKS !!!!!
Just put in new module and try "public" functions 🙂
Cheers,
Jure
___________________
Option Explicit
'// Module: OpenFile
'//
'// 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.
'Vba6 True Visual Basic for Applications, version 6.0 compatible.
'Vba6 False not Visual Basic for Applications, version 6.0 compatible.
'Vba7 True Visual Basic for Applications, version 7.0 compatible.
'Vba7 False not Visual Basic for Applications, version 7.0 compatible.
'Win16 False Indicates development environment is not 16-bit compatible.
'Win32 True 32-bit compatible.
'Win64 True 64-bit compatible.
' 64 bit declarations
'http://www.jkp-ads.com/articles/apideclarations.asp
'http://www.jkp-ads.com/articles/apideclarations.asp
#If Win64 Then
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
Private Declare PtrSafe Function GetVersionExA Lib "kernel32" _
(lpVersionInformation As OSVERSIONINFO) As Integer
Private Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128
End Type
Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
(ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, _
ByVal lpParameters As String, ByVal lpDirectory As String, _
ByVal nShowcmd As Long) As Long
Function GetFolderName(Msg As String) As String
' returns the name of the folder selected by the user
Dim bInfo As BROWSEINFO, path As String, r As Long
Dim x As Long, pos As Integer
bInfo.pidlRoot = 0& ' Root folder = Desktop
If IsMissing(Msg) Then
bInfo.lpszTitle = "Izberi mapo"
' the dialog title
Else
bInfo.lpszTitle = Msg ' the dialog title
End If
bInfo.ulFlags = &H1 ' Type of directory to return
x = SHBrowseForFolder(bInfo) ' display the dialog
' Parse the result
path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
GetFolderName = Left(path, pos - 1)
Else
GetFolderName = ""
End If
End Function
Private Type BROWSEINFO ' used by the function GetFolderName
hOwner As LongPtr
pidlRoot As LongPtr
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As LongPtr
lParam As LongPtr
iImage As Long
End Type
Public Sub RunWord(ByVal PP As String)
Dim Handle As Long
Dim operation As String
Dim lpFile As String
Dim lpParm As String
Dim lpDir As String
Dim nShowcmd As Long
Handle = ThisDrawing.HWND32 'Handle calling application
operation = "open" 'Operation performed
lpFile = Mid(PP, 4) 'Name and path of the file to be opened less drive letter
lpParm = "" 'Set to null string in VB
lpDir = Left(PP, 3) '3 character drive ("C:\")
nShowcmd = 1 'Show application window (Hidden, Max, etc.)
ShellExecute Handle, operation, lpFile, lpParm, lpDir, nShowcmd
End Sub
#ElseIf Win32 Then ' !=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=
Private Declare Function GetOpenFileName Lib "comdlg32.dll" _
Alias "GetOpenFileNameA" (OFN As OPENFILENAME) As Boolean
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
Private Declare Function GetVersionExA Lib "kernel32" _
(lpVersionInformation As OSVERSIONINFO) As Integer
Private Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128
End Type
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
(ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, _
ByVal lpParameters As String, ByVal lpDirectory As String, _
ByVal nShowcmd As Long) As Long
Function GetFolderName(Msg As String) As String
' returns the name of the folder selected by the user
Dim bInfo As BROWSEINFO, path As String, r As Long
Dim x As Long, pos As Integer
bInfo.pidlRoot = 0& ' Root folder = Desktop
If IsMissing(Msg) Then
bInfo.lpszTitle = "Izberi mapo"
' the dialog title
Else
bInfo.lpszTitle = Msg ' the dialog title
End If
bInfo.ulFlags = &H1 ' Type of directory to return
x = SHBrowseForFolder(bInfo) ' display the dialog
' Parse the result
path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
GetFolderName = Left(path, pos - 1)
Else
GetFolderName = ""
End If
End Function
Private Type BROWSEINFO ' used by the function GetFolderName
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Public Sub RunWord(ByVal PP As String)
Dim Handle As Long
Dim operation As String
Dim lpFile As String
Dim lpParm As String
Dim lpDir As String
Dim nShowcmd As Long
Handle = ThisDrawing.hWnd 'Handle calling application
operation = "open" 'Operation performed
lpFile = Mid(PP, 4) 'Name and path of the file to be opened less drive letter
lpParm = "" 'Set to null string in VB
lpDir = Left(PP, 3) '3 character drive ("C:\")
nShowcmd = 1 'Show application window (Hidden, Max, etc.)
ShellExecute Handle, operation, lpFile, lpParm, lpDir, nShowcmd
End Sub
#End If
Private Sub FindFile(ByRef Filepath As String, sFilter 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 = VBA.String(257, 0)
OpenFile.nMaxFile = Len(OpenFile.lpstrFile) - 1
OpenFile.lpstrFileTitle = OpenFile.lpstrFile
OpenFile.nMaxFileTitle = OpenFile.nMaxFile
'OpenFile.lpstrInitialDir = Application.ActiveDocument.path
If Filepath > "" Then
OpenFile.lpstrInitialDir = Filepath
Else
OpenFile.lpstrInitialDir = "C:\"
End If
OpenFile.lpstrTitle = "Find " + sFilter
OpenFile.flags = 0
lReturn = GetOpenFileName(OpenFile)
If lReturn = 0 Then
cancelled = True
Filepath = vbNullString
Else
cancelled = False
Filepath = VBA.Trim(OpenFile.lpstrFile)
Filepath = Replace(Filepath, VBA.Chr(0), vbNullString)
End If
Exit Sub
errTrap:
Exit Sub
Resume
End Sub
Public Function getFiled(sPath As String, sExt As String, sDescr As String) As String
'(getfiled "Title" "Directory Path and/or File name" "File Extension" Flag)
Dim bCancelled As Boolean
Dim fType As String
fType = sDescr + " (" + sExt + ")" + VBA.Chr(0) + sExt
FindFile sPath, fType, bCancelled
If bCancelled Then getFiled = "" Else getFiled = sPath
End Function
'==================================== TESTING ROUTINES ==========================================================
'Private Sub Filepath_Click()
' Label1.Caption = getFiled("D:\", "tif", "Raster")
'End Sub
Public Function getVersion() As String
Dim osinfo As OSVERSIONINFO
Dim retvalue As Integer
Dim Wver As String
Dim Vname As String
osinfo.dwOSVersionInfoSize = 148
osinfo.szCSDVersion = VBA.Space$(128)
retvalue = GetVersionExA(osinfo)
Wver = osinfo.dwMajorVersion & "." & osinfo.dwMinorVersion
Select Case Wver
Case "6.2": Vname = "Windows 8"
'Case "6.2": Vname = "Windows Server 2012"
Case "6.1": Vname = "Windows 7"
'Case "6.1": Vname = "Windows Server 2008 R2"
Case "6.0": Vname = "Windows Server 2008"
'Case "6.0": Vname = "Windows Vista"
'Case "5.2": Vname = "Windows Server 2003 R2"
'Case "5.2": Vname = "Windows Home Server"
Case "5.2": Vname = "Windows Server 2003"
'Case "5.2": Vname = "Windows XP Professional x64 Edition"
Case "5.1": Vname = "Windows XP"
Case "5.0": Vname = "Windows 2000"
End Select
'getVersion = Wver + "_" + Vname
getVersion = Vname
End Function
Private Sub TestEnvionment()
Dim a$
#If Win64 Then
a$ = a$ + "Win64=True" + vbCrLf
#Else
a$ = a$ + "Win64=False" + vbCrLf
#End If
#If Win32 Then
a$ = a$ + "Win32=True" + vbCrLf
#Else
a$ = a$ + "Win32=False" + vbCrLf
#End If
#If Win16 Then
a$ = a$ + "Win16=True" + vbCrLf
#Else
a$ = a$ + "Win16=False" + vbCrLf
#End If
#If VBA6 Then
a$ = a$ + "Vba6=True" + vbCrLf
#Else
a$ = a$ + "Vba6=False" + vbCrLf
#End If
#If VBA7 Then
a$ = a$ + "Vba7=True" + vbCrLf
#Else
a$ = a$ + "Vba7=False" + vbCrLf
#End If
MsgBox a$
End Sub
Hi ,
i tryed this but it tells me binfo is not defined, can some one know this ?
should start with
with binfo
...
....
End with
thanks
1. Make sa Form with 2 buttons:
[TestEnvionment]
[Filepath]
2. copy/paste the code below:
This should work (just tested 2 minutes ago).
Cheers,
Jure
----------------- START CODE ---------------------
Option Explicit
'// Module: OpenFile
'//
'// 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.
'Vba6 True Visual Basic for Applications, version 6.0 compatible.
'Vba6 False not Visual Basic for Applications, version 6.0 compatible.
'Vba7 True Visual Basic for Applications, version 7.0 compatible.
'Vba7 False not Visual Basic for Applications, version 7.0 compatible.
'Win16 False Indicates development environment is not 16-bit compatible.
'Win32 True 32-bit compatible.
'Win64 True 64-bit compatible.
#If Win64 Then
Private Declare PtrSafe Function GetOpenFileName Lib "comdlg32.dll" _
Alias "GetOpenFileNameA" (OFN As OPENFILENAME) As Boolean
Private Declare PtrSafe Function GetVersionExA Lib "kernel32" _
(lpVersionInformation As OSVERSIONINFO) As Integer
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
Private Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128
End Type
#ElseIf Win32 Then
Private Declare Function GetOpenFileName Lib "comdlg32.dll" _
Alias "GetOpenFileNameA" (OFN As OPENFILENAME) As Boolean
Private Declare Function GetVersionExA Lib "kernel32" _
(lpVersionInformation As OSVERSIONINFO) As Integer
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
Private Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128
End Type
#End If
Private Sub UserForm_Activate()
#If VBA7 Then
#Else
MsgBox "Only Autocad 2014 allowed"
End
#End If
End Sub
Public Function getVersion() As String
Dim osinfo As OSVERSIONINFO
Dim retvalue As Integer
Dim Wver As String
Dim Vname As String
osinfo.dwOSVersionInfoSize = 148
osinfo.szCSDVersion = VBA.Space$(128)
retvalue = GetVersionExA(osinfo)
Wver = osinfo.dwMajorVersion & "." & osinfo.dwMinorVersion
Select Case Wver
Case "6.2": Vname = "Windows 8"
'Case "6.2": Vname = "Windows Server 2012"
Case "6.1": Vname = "Windows 7"
'Case "6.1": Vname = "Windows Server 2008 R2"
Case "6.0": Vname = "Windows Server 2008"
'Case "6.0": Vname = "Windows Vista"
'Case "5.2": Vname = "Windows Server 2003 R2"
'Case "5.2": Vname = "Windows Home Server"
Case "5.2": Vname = "Windows Server 2003"
'Case "5.2": Vname = "Windows XP Professional x64 Edition"
Case "5.1": Vname = "Windows XP"
Case "5.0": Vname = "Windows 2000"
End Select
'getVersion = Wver + "_" + Vname
getVersion = Vname
End Function
Public Sub FindFile(ByRef Filepath As String, sFilter 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 = VBA.String(257, 0)
OpenFile.nMaxFile = Len(OpenFile.lpstrFile) - 1
OpenFile.lpstrFileTitle = OpenFile.lpstrFile
OpenFile.nMaxFileTitle = OpenFile.nMaxFile
'OpenFile.lpstrInitialDir = Application.ActiveDocument.path
If Filepath > "" Then
OpenFile.lpstrInitialDir = Filepath
Else
OpenFile.lpstrInitialDir = "C:\"
End If
OpenFile.lpstrTitle = "Find " + sFilter
OpenFile.flags = 0
lReturn = GetOpenFileName(OpenFile)
If lReturn = 0 Then
cancelled = True
Filepath = vbNullString
Else
cancelled = False
Filepath = VBA.Trim(OpenFile.lpstrFile)
Filepath = Replace(Filepath, VBA.Chr(0), vbNullString)
End If
Exit Sub
errTrap:
Exit Sub
Resume
End Sub
Private Function getFiled(sPath As String, sExt As String, sDescr As String) As String
'(getfiled "Title" "Directory Path and/or File name" "File Extension" Flag)
Dim bCancelled As Boolean
Dim fType As String
fType = sDescr + " (*." + sExt + ")" + VBA.Chr(0) + "*." + sExt
FindFile sPath, fType, bCancelled
If bCancelled Then getFiled = "" Else getFiled = sPath
End Function
Private Sub Filepath_Click()
Label1.Caption = getFiled("D:\", "tif", "Raster")
End Sub
Private Sub TestEnvionment_Click()
Dim a$
#If Win64 Then
a$ = a$ + "Win64=True" + vbCrLf
#Else
a$ = a$ + "Win64=False" + vbCrLf
#End If
#If Win32 Then
a$ = a$ + "Win32=True" + vbCrLf
#Else
a$ = a$ + "Win32=False" + vbCrLf
#End If
#If Win16 Then
a$ = a$ + "Win16=True" + vbCrLf
#Else
a$ = a$ + "Win16=False" + vbCrLf
#End If
#If VBA6 Then
a$ = a$ + "Vba6=True" + vbCrLf
#Else
a$ = a$ + "Vba6=False" + vbCrLf
#End If
#If VBA7 Then
a$ = a$ + "Vba7=True" + vbCrLf
#Else
a$ = a$ + "Vba7=False" + vbCrLf
#End If
MsgBox a$
Dim Vrstica As Variant
Vrstica = Split(Application.Path, "\")
Dim hostName As String
hostName = VBA.Environ$("computername")
Dim acadVer As String
acadVer = Vrstica(UBound(Vrstica))
Dim WinVersion As String
WinVersion = getVersion
Open ThisDrawing.Path + "\Env " + WinVersion + " " + hostName + " " + acadVer + ".txt" For Output As #1
Print #1, ThisDrawing.FullName
Print #1, Application.FullName
Print #1, a$
Close #1
End Sub
----------------- END CODE ---------------------
To select multople files, in procedure "FindFile" just replace
OpenFile.flags = 0
with
OpenFile.flags = &H80200 ' OFN_EXPLORER + OFN_ALLOWMULTISELECT
It is up to you, to split resulting string to multiple filenames 🙂
Cheers,
Jure
The code above should be pasted to "Module".
In the main form you can use all "Public" functions.
Hope this helps,
Jure
Sorry if this sounds like a stupid question, but Im guessing I create a userform and insert the code into the module?
Is this what you meant?
Don't try building your own dialog, just use the windows dialogs via api. See the last post in >>this thread<<. Download FileDialogs.zip file I attached there.