API VBA: Open Dialog

Is it possible to access this dialog through VBA. I just want to allow a
user to search for a file and then just get the full name including
directory structure to pass to a function.

Thanks,
Corey

 

Sure.
Once you have a userform in your SW Macro, the menu selection Tools -
Additional Controls should be enabled.
This brings up a list, from which you can select Microsoft Common Dialog
Control. This may not be installed by the VBA, but if you have VB on your
computer, you've got it and can use it here.

Regards,
Brenda

 

i dont know about vba because its a chopped up version of visual
basic. but vb6.0 and later. you can create a your own open dialog
boxs. this is not a part of solidworks api but is a part of visual
basic.

 

Is it possible to access this dialog through VBA. I just want to allow a

Common dialogs can be created as well by calling Windows API functions. For
open dialog box, there is a function GetOpenFileName. In VB you would need
to declare that function like

Declare Function GetOpenFileName Lib "Comdlg32" (lpofn As OPENFILENAME) As
Boolean

You would also need to declare OPENFILENAME structure as defined in WIN api
help, like

Type OPENFILENAME
lStructSize as Long
hwndOwner as Long
... etc
End Type

Showing Open dialog box would need the following steps:

- Create an instance of OPENFILENAME structure
- Fill in the required values
- Call OpenFileName function
- Read the selected file name and path from the structure

More details can be found by seacrhing MSDN, see msdn.microsoft.com. I don't
know, however, if that can be done in VBA.

-h-

 

Is it possible to access this dialog through VBA.

Here is a module I use for such things. It works in VB and VBA. It has
file open, file save, and browse for folder dialogs. There is a "Sub
Main" that demos some of the features, run that to get a feel for it.
The "OpenFiles" routine allows for setting a non-local directory as a
seed directory, as well as allowing/disallowing multiple file
selections thru the dialog.

' --- snip --------- snip -------------- snip --------------


' CommonDialog.Bas
' written by rocheey for anyone who wants it

' API implementation of Common Dialog
' works in VBA and VB
'
' Contains 3 main routines:
' "SaveFile" Pops up File Save Dialog
' "OpenFiles" File Open Dialog
' "BrowseForFolder" Self explanatory

' Run "Main" subroutine to see implementations of these routines


Const OFN_ALLOWMULTISELECT = &H200
Const OFN_CREATEPROMPT = &H2000
Const OFN_ENABLEHOOK = &H20
Const OFN_ENABLETEMPLATE = &H40
Const OFN_ENABLETEMPLATEHANDLE = &H80
Const OFN_EXPLORER = &H80000
Const OFN_EXTENSIONDIFFERENT = &H400
Const OFN_FILEMUSTEXIST = &H1000
Const OFN_HIDEREADONLY = &H4
Const OFN_LONGNAMES = &H200000
Const OFN_NOCHANGEDIR = &H8
Const OFN_NODEREFERENCELINKS = &H100000
Const OFN_NOLONGNAMES = &H40000
Const OFN_NONETWORKBUTTON = &H20000
Const OFN_NOREADONLYRETURN = &H8000
Const OFN_NOTESTFILECREATE = &H10000
Const OFN_NOVALIDATE = &H100
Const OFN_OVERWRITEPROMPT = &H2
Const OFN_PATHMUSTEXIST = &H800
Const OFN_READONLY = &H1
Const OFN_SHAREAWARE = &H4000
Const OFN_SHAREFALLTHROUGH = 2
Const OFN_SHAREWARN = 0
Const OFN_SHARENOWARN = 1
Const OFN_SHOWHELP = &H10
Const OFS_MAXPATHNAME = 128

Const BIF_RETURNONLYFSDIRS = &H1
Const BIF_DONTGOBELOWDOMAIN = &H2
Const BIF_STATUSTEXT = &H4
Const BIF_RETURNFSANCESTORS = &H8
Const BIF_BROWSEFORCOMPUTER = &H1000
Const BIF_BROWSEFORPRINTER = &H2000
Const MAX_PATH = 260

Const OFS_FILE_OPEN_FLAGS = OFN_EXPLORER Or OFN_HIDEREADONLY Or
OFN_LONGNAMES Or OFN_CREATEPROMPT Or OFN_NODEREFERENCELINKS
Const OFS_FILE_SAVE_FLAGS = OFN_EXPLORER Or OFN_LONGNAMES Or
OFN_OVERWRITEPROMPT Or OFN_HIDEREADONLY
Const OFS_MULTIFILE_OPEN_FLAGS = OFN_ALLOWMULTISELECT Or
OFN_HIDEREADONLY Or OFN_EXPLORER Or OFN_LONGNAMES Or OFN_CREATEPROMPT
Or OFN_NODEREFERENCELINKS


Type OPENFILENAME
nStructSize As Long
hwndOwner As Long
hInstance As Long
sFilter As String
sCustomFilter As String
nCustFilterSize As Long
nFilterIndex As Long
sFile As String
nFileSize As Long
sFileTitle As String
nTitleSize As Long
sInitDir As String
sDlgTitle As String
flags As Long
nFileOffset As Integer
nFileExt As Integer
sDefFileExt As String
nCustDataSize As Long
fnHook As Long
sTemplateName As String
End Type

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

Dim FileInfo As OPENFILENAME

Declare Function GetOpenFileName Lib "comdlg32.dll" Alias
"GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Declare Function GetSaveFileName Lib "comdlg32.dll" Alias
"GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long
Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias
"SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String)
As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" Alias
"SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)
Declare Function SetCurrentDirectoryA Lib "Kernel32" (ByVal lpszCurDir
As String) As Long
Declare Function GetDesktopWindow Lib "user32" () As Long

Private Sub Main()

msg$ = "First, call up the file open dialog." & vbCrLf & vbCrLf
msg$ = msg$ & "We we allow multiple file selections," & vbCrLf
msg$ = msg$ & "will seed the current directory to 'C:\'" & vbCrLf
msg$ = msg$ & "and filter for text files." & vbCrLf & vbCrLf
MsgBox msg$, 32, "File Open Test call"

Dim retFiles As Variant
' call the dialog
retFiles = OpenFiles("*.txt", "Text Files", "Open Files Demo",
True, "C:\")
' check the return
If IsEmpty(retFiles) Then
MsgBox "No File(s) Selected.", 32, "End of File Open Demo"
Else
msg$ = "You selected the following files:" & vbCrLf & vbCrLf
' Loop thru all the returned files
For I% = 0 To UBound(retFiles)
msg$ = msg$ & retFiles(I%) & vbCrLf
Next I%
msg$ = msg$ & vbCrLf
MsgBox msg$, 32, "End of File Open Demo"
End If

' Now demo the browse for folder call
msg$ = "Now for the Browse for Folder routine." & vbCrLf & vbCrLf
msg$ = msg$ & "You will be prompted to type in the " & vbCrLf
msg$ = msg$ & "Caption for the Dialog. This demo will" & vbCrLf
msg$ = msg$ & "trim the Caption to 32 characters." & vbCrLf
MsgBox msg$, 32, "Browse for Folder Demo"

Dim retStr As String
Const MyCaption As String = "My Caption"
retStr = InputBox("Type in a name for the dialog", "Browse for
Folder demo", MyCaption)

If retStr = "" Then retStr = MyCaption Else retStr = Left$(retStr,
32)

' Call up the browse for folder dialog
Dim retPath As String
retPath = BrowseForFolder(retStr)

' check the return path
If retPath = "" Then
MsgBox "No Folder selected." & vbCrLf & vbCrLf, 32, "Browse
for Folder Demo"
Else
msg$ = "You selected the following folder : " & vbCrLf &
vbCrLf
msg$ = msg$ & retPath & vbCrLf & vbCrLf
MsgBox msg$, 32, "Browse for Folder Demo"
End If




End Sub

' +--------------------------------------------------------------------+
' | -= Main sub to call File SAVE Dialog =-
|
' |
|
' | Parameters: FileName$ is a variable that the name of the SAVED
|
' | file name is returned in. You do NOT have to pass
|
' | a filename to this routine, one is returned. Note
|
' | that the Win API checks for, and prompts, if the
|
' | filename already exists.
|
' |
|
' | FileExt$ is the file extension name you wish the
|
' | Dialog box to use, for default extension, file
|
' | listings, and availablity innthe drop-down "file
|
' | type" box.
|
' |
|
' | FileDesc$ is a descriptive name for the File Name
|
' | Extension, used to describe the filetype in the drop
|
' | down type box.
|
' |
|
' +--------------------------------------------------------------------+
Function SaveFile(FileName$, FileExt$, FileDesc$, WinTitle$) As String

Dim strCurName As String
Dim strFill, strFilter As String
Dim lngReturn, ShortSize As Long


On Error GoTo Err_Control
strCurName = FileName$

strFill = Chr(0)
FileInfo.nStructSize = Len(FileInfo)
FileInfo.hwndOwner = GetDesktopWindow

'This section is for the filter drop down list
strFilter = FileDesc$ & strFill & FileExt$ & strFill
strFilter = strFilter & "All Files" & strFill & "*.*" & strFill &
strFill
FileInfo.sFilter = strFilter
'This is the default information for the dialog
FileInfo.sFile = FileName$ & Space$(1024) & strFill
FileInfo.nFileSize = Len(FileInfo.sFile)
FileInfo.sDefFileExt = FileExt$

FileInfo.sFileTitle = Space(512)
FileInfo.nTitleSize = Len(FileInfo.sFileTitle)
FileInfo.sInitDir = CurDir
FileInfo.sDlgTitle = WinTitle$

' use below to call save dialog
FileInfo.flags = OFS_FILE_SAVE_FLAGS
lngReturn = GetSaveFileName(FileInfo)

If lngReturn Then
SaveFile = FileInfo.sFile
End If

On Error GoTo 0
Exit Function

Err_Control:
'Just get out, to many things to account for
MsgBox Err.Description, vbCritical, "Too many errors, aborting"
End Function


' +--------------------------------------------------------------------+
' | -= OpenFiles =-
|
' |
|
' | Parameters:FileExt is the file extension name you wish the
|
' | Dialog box to use, for default extension, file
|
' | listings, and availablity in the drop-down "file
|
' | type" box.
|
' |
|
' | FileDesc is a descriptive name for the File Name
|
' | Extension, used to describe the filetype in the drop
|
' | down type box.
|
' |
|
' | WindowCaption is the string you wish to display
|
' | in the dialog title bar
|
' |
|
' | AllowMulti is a boolean describing whether you wish to
|
' | allow multiple files to be selected
|
' |
|
' | StartDir Is a string describing the Folder name in
|
' | which you want the dialog to be displaying on open.
|
' |
|
' | Returns:
|
' | a variant safearray of the qualified
filespec/pathspecs |
' | If user does not select anything, variant is EMPTY.
|
' | If user selects one file, it will be UBOUND(0)
|
' |
|
' +--------------------------------------------------------------------+
Function OpenFiles(FileExt As String, FileDesc As String,
WindowCaption As String, AllowMulti As Boolean, StartDir As String) As
Variant

' filedesc=File description for drop down box
' WindowCaption = caption of the file window
' parent hwnd - usew dewsktophwnd?

Dim strCurName As String
Dim lngReturn As Long
Dim strFill As String
Dim strFilter As String
Dim CurrentDir As String
Dim strReturnFiles As String
Dim varReturnFiles As Variant

On Error GoTo Err_Control
strCurName = ""

CurrentDir = CurDir ' store current directory
If StartDir > "" Then
SetCurDir StartDir ' set current directory to passed dir
End If

strFill = Chr(0)
FileInfo.nStructSize = Len(FileInfo)
FileInfo.hwndOwner = GetDesktopWindow ' return hwnd of desktop

'This section is for the filter drop down list
strFilter = FileDesc & strFill & FileExt & strFill
strFilter = strFilter & "All Files" & strFill & "*.*" & strFill &
strFill
FileInfo.sFilter = strFilter

'This is the default information for the dialog
FileInfo.sFile = strCurName & Space$(1024) & strFill
FileInfo.nFileSize = Len(FileInfo.sFile)
FileInfo.sDefFileExt = FileExt

FileInfo.sFileTitle = Space(512)
FileInfo.nTitleSize = Len(FileInfo.sFileTitle)
FileInfo.sInitDir = CurDir
FileInfo.sDlgTitle = WindowCaption

' use below to call open dialog
' optionally use single or multiple selection open flags
If AllowMulti = True Then
FileInfo.flags = OFS_MULTIFILE_OPEN_FLAGS
Else
FileInfo.flags = OFS_FILE_OPEN_FLAGS
End If
lngReturn = GetOpenFileName(FileInfo)

ChDir CurrentDir ' reset current directory
If lngReturn Then ' all went well, see if we have multi
files to parse
strReturnFiles = FileInfo.sFile

If AllowMulti = True Then
varReturnFiles = SeedFileList(strReturnFiles)
Else
varReturnFiles = Array(strReturnFiles)
End If
Else
Exit Function
End If


OpenFiles = varReturnFiles

On Error GoTo 0
Exit Function

Err_Control:
'Just get out, to many things to account for
MsgBox Err.Description, vbCritical, "Too many errors, aborting"
Err.Clear
End Function



' +--------------------------------------------------------------------+
' | -= BrowseForFolder =-
|
' |
|
' | Pops up Browse For Folder dialog
|
' |
|
' | Parameters: WindowTitle: Caption you wish to see in the dialog
|
' |
|
' | Returns: Path Name to folder if selected; empty string if
|
' | user cancels.
|
' +--------------------------------------------------------------------+
Function BrowseForFolder(WindowTitle As String) As String
' call the Browse for folders dialog, returns Pathname

Dim bi As BROWSEINFO
Dim pidl As Long
Dim path As String
Dim pos As Integer
Dim pathRet As String
Dim lastChar As String


bi.hOwner = GetDesktopWindow ' get hwnd
bi.pidlRoot = 0 'Pointer to the item identifier list
bi.lpszTitle = WindowTitle 'message to be displayed in the Browse
dialog
bi.ulFlags = BIF_RETURNONLYFSDIRS 'the type of folder to return.
pidl = SHBrowseForFolder(bi) 'show the browse for folders dialog
path = Space$(MAX_PATH) 'parse the user's returned folder
selection contained in pidl

If SHGetPathFromIDList(ByVal pidl, ByVal path) Then
pos = InStr(path, Chr$(0))
pathRet = Left$(path, pos - 1)
lastChar = Right$(pathRet, 1)
If lastChar <> "/" And lastChar <> "\" Then pathRet = pathRet
& "\"
BrowseForFolder = pathRet
End If

Call CoTaskMemFree(pidl)

End Function


Function SetCurDir(NetPath As String) As Boolean
' uses API call to set CurDir for file open/save
' (VB only allows local dir for CurDir)

Dim FName As String, CDir As String
CDir = CurDir$
SetCurDir = SetCurrentDirectoryA(NetPath)

End Function


Function SeedFileList(nullStr As String) As Variant
' processes return from "OpenFiles" routine, when multiple files are
selected
' Win API returns a string embedded with many files,
' each terminated with an ascii zero. Takes this string and returns
' a varaint safearray of fully qualified Filespecs (or empty if none)

Dim strLoc() As Integer
Dim strCounter As Integer
Dim FileCounter As Integer
Dim FileSpec() As String
Dim strLen%, I%, Char$, NextSeekStartPos%, SeekLength%
Dim LastSeekPos%, NextSeekEndPos%, ThisStr$, FilePath$, SwapStr$

If Len(nullStr) = 0 Then Exit Function
strCounter = -1
FileCounter = -1

strLen% = Len(nullStr)
For I% = 1 To strLen%
Char$ = Mid$(nullStr, I%, 1)
If Char$ = Chr$(0) Then
strCounter = strCounter + 1
ReDim Preserve strLoc(0 To strCounter) As Integer
strLoc(strCounter) = I%
End If
Next I%

' now Loop thru and find where 2 ascii nulls are next to each
other. thats where the string 'array' ends
If strCounter > 1 Then ' if only 2, then only one string
For I% = 0 To (strCounter - 1)
If strLoc(I%) + 1 = strLoc(I% + 1) Then ' byte locations
next to eacxh other
strCounter = I% ' end at the first of the 2
matching null sets
Exit For
End If
Next I%
Else
strCounter = 0 ' set to 0-based "1" index
End If


' Now that we've changed the counter, lets go back and get the
strings
LastSeekPos% = 0 ' initialize last found location
For I% = 0 To strCounter
NextSeekStartPos% = LastSeekPos% + 1
NextSeekEndPos% = strLoc(I%) - 1
SeekLength% = NextSeekEndPos% - NextSeekStartPos% + 1
ThisStr$ = Mid$(nullStr, NextSeekStartPos%, SeekLength%)

If I% = 0 Then ' if first entry
If strCounter > 0 Then ' and there is more than one
file, then first entry is the path, dont add to list
FilePath$ = ThisStr$
If Right(FilePath$, 1) <> "\" Then FilePath$ =
FilePath$ & "\" ' append dir char
Else ' first of one entry; add it to the list
FileCounter = FileCounter + 1
ReDim Preserve FileSpec(0 To FileCounter) As String
FileSpec(FileCounter) = ThisStr$
End If
Else ' Second or Greater entry, PREpend pathspec
ThisStr$ = FilePath$ & ThisStr$
FileCounter = FileCounter + 1
ReDim Preserve FileSpec(0 To FileCounter) As String
FileSpec(FileCounter) = ThisStr$
End If
LastSeekPos% = strLoc(I%)
Next I%

' Now build an output string (variant safearray), nulls removed
If FileCounter > -1 Then
If FileCounter > 0 Then ' reverse first and last entries
(always comes back crooked!)
SwapStr$ = FileSpec(FileCounter)
FileSpec(FileCounter) = FileSpec(0)
FileSpec(0) = SwapStr$
End If
SeedFileList = FileSpec()
End If


End Function








' --- snip --------- snip -------------- snip --------------

 

I will try that out, thank you.

Corey Scheich