VBA 7.1 CommonDialog lost

[jure]

In VBA 7.1, Autocad 2014 there is no way to open file selection window.

Can anyone advose how to:

CommonDialog1.ShowOpen

Thanks,

Jure

[norman.yuan]

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. 

[Eydelmana]

So, what about real decision. I have the same problem.

[jure]

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

[Eydelmana]

Thank you very much. It works good.

[marnor]

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

[jure]

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 ---------------------

[marnor]

THANKS,

[rlester]

Could you explain how to set this to select multiple files...

Thanks

[jure]

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

[antiaddict]

I'm limited on my code knowledge. So if I have existing code what do I do to make it work? Where do I add the above coding?

Thanks

[marnor]

Can you give me more info

[jure]

The code above should be pasted to "Module".

In the main form you can use all "Public" functions.

Hope this helps,

Jure

[stefan.costanzo]

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?

[bhuhn]

Does anyone have up-to-date code for this? Simply copy and pasting doesn't seem to work anymore.

[Ed.Jobe]

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.