topic Re: VBA 7.1 CommonDialog lost in VBA Forum

VBA 7.1 CommonDialog lost

JureSpiler — Tue, 09 Apr 2013 10:13:45 GMT

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

Can anyone advose how to:

CommonDialog1.ShowOpen

Thanks,

Jure

Re: VBA 7.1 CommonDialog lost

norman.yuan — Tue, 09 Apr 2013 14:03:56 GMT

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.

Re: VBA 7.1 CommonDialog lost

Eydelmana — Wed, 11 Sep 2013 08:27:31 GMT

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

Re: VBA 7.1 CommonDialog lost

JureSpiler — Wed, 11 Sep 2013 08:46:12 GMT

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

Re: VBA 7.1 CommonDialog lost

Eydelmana — Wed, 11 Sep 2013 09:58:42 GMT

Thank you very much. It works good.

Re: VBA 7.1 CommonDialog lost

Anonymous — Mon, 23 Sep 2013 11:26:26 GMT

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

Re: VBA 7.1 CommonDialog lost

JureSpiler — Mon, 23 Sep 2013 11:50:04 GMT

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

Re: VBA 7.1 CommonDialog lost

Anonymous — Mon, 23 Sep 2013 16:29:29 GMT

THANKS,

Re: VBA 7.1 CommonDialog lost

rlester — Wed, 02 Oct 2013 20:34:27 GMT

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

Thanks

Re: VBA 7.1 CommonDialog lost

JureSpiler — Thu, 03 Oct 2013 05:48:50 GMT

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

Re: VBA 7.1 CommonDialog lost

Anonymous — Thu, 04 Sep 2014 16:59:15 GMT

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

Re: VBA 7.1 CommonDialog lost

Anonymous — Thu, 04 Sep 2014 20:01:41 GMT

Can you give me more info

Re: VBA 7.1 CommonDialog lost

JureSpiler — Fri, 05 Sep 2014 03:43:13 GMT

The code above should be pasted to "Module".

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

Hope this helps,

Jure

Re: VBA 7.1 CommonDialog lost

Anonymous — Thu, 02 Mar 2017 22:34:20 GMT

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?

Re: VBA 7.1 CommonDialog lost

bhuhn — Wed, 05 Jul 2017 18:56:19 GMT

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

Re: VBA 7.1 CommonDialog lost

Ed__Jobe — Wed, 05 Jul 2017 22:40:52 GMT

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.