Here's CommonDialog.cls by Frank Oquendo
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "CommonDialog"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
' COMMONDIALOG.CLS v1.2 (Last updated 6/15/2000)
' Copyright 2000 by Frank Oquendo
'
' Permission to use, copy, modify, and distribute this software
' for any purpose and without fee is hereby granted, provided
' that the above copyright notice appears in all copies and
' that both that copyright notice and the limited warranty and
' restricted rights notice below appear in all supporting
' documentation.
'
' FRANK OQUENDO (THE AUTHOR) PROVIDES THIS PROGRAM "AS IS" AND WITH
' ALL FAULTS. THE AUTHOR SPECIFICALLY DISCLAIMS ANY IMPLIED WARRANTY
' OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR USE. THE AUTHOR
' DOES NOT WARRANT THAT THE OPERATION OF THE PROGRAM WILL BE
' UNINTERRUPTED OR ERROR FREE.
'
' Use, duplication, or disclosure by the U.S. Government is subject to
' restrictions set forth in FAR 52.227-19 (Commercial Computer
' Software - Restricted Rights) and DFAR 252.227-7013(c)(1)(ii)
' (Rights in Technical Data and Computer Software), as applicable.
'
' CommonDialog.cls allows developers to access the Windows Open, Save
' and Browse For Folder dialogs without the need for an OCX.
'
' Notes:
' All code for this class module is publicly available througout various posts
' at news://discussion.autodesk.com/autodesk.autocad.customization.vba as well
' as http://msdn.microsoft.com. I do not claim copyright or authorship on code
' presented in these posts, only on this compilation of that code.
'
' Dependencies:
' Use of this class module requires the following files:
' 1. shell32.dll (SHBrowseForFolder)
' 2. comdlg32.dll (GetOpenFileName and GetSaveFileName)
Option Explicit
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 SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" _
(lpBrowseInfo As BROWSEINFO) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" _
(ByVal pidl As Long, _
ByVal pszPath As String) As Long
Private Declare Sub CoTaskMemFree Lib "ole32.dll" _
(ByVal pv As Long)
Private Declare Function CommDlgExtendedError Lib "comdlg32.dll" () 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
Private 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
Private Const ERROR_SUCCESS As Long = 0
Private Const MAX_PATH As Long = 260
Private Const BIF_RETURNONLYFSDIRS As Long = &H1
Private mvarPath As String
Private mvarInitDir As String
Private mvarDialogTitle As String
Private mvarFilter As String
Private mvarUserFilter As String
Private mvarDefaultExt As String
Private mvarFileName As String
Private mvarFileTitle As String
Private mvarFilterIndex As Integer
Private mvarFlags As Long
Private mvarMaxFileSize As Integer
Private mvarErrorCode As Long
Private mvarErrorDescription As String
Public Enum cdlFlags
OFN_ALLOWMULTISELECT = &H200
OFN_CREATEPROMPT = &H2000
OFN_ENABLEHOOK = &H20
OFN_ENABLETEMPLATE = &H40
OFN_ENABLETEMPLATEHANDLE = &H80
OFN_EXPLORER = &H80000
OFN_EXTENSIONDIFFERENT = &H400
OFN_FILEMUSTEXIST = &H1000
OFN_HIDEREADONLY = &H4
OFN_LONGNAMES = &H200000
OFN_NOCHANGEDIR = &H8
OFN_NODEREFERENCELINKS = &H100000
OFN_NOLONGNAMES = &H40000
OFN_NONETWORKBUTTON = &H20000
OFN_NOREADONLYRETURN = &H8000
OFN_NOTESTFILECREATE = &H10000
OFN_NOVALIDATE = &H100
OFN_OVERWRITEPROMPT = &H2
OFN_PATHMUSTEXIST = &H800
OFN_READONLY = &H1
OFN_SHAREAWARE = &H4000
OFN_SHAREFALLTHROUGH = 2
OFN_SHARENOWARN = 1
OFN_SHAREWARN = 0
OFN_SHOWHELP = &H10
End Enum
Public Enum cdlError
CDERR_DIALOGFAILURE = &HFFFF
CDERR_FINDRESFAILURE = &H6
CDERR_GENERALCODES = &H0
CDERR_INITIALIZATION = &H2
CDERR_LOADRESFAILURE = &H7
CDERR_LOADSTRFAILURE = &H5
CDERR_LOCKRESFAILURE = &H8
CDERR_MEMALLOCFAILURE = &H9
CDERR_MEMLOCKFAILURE = &HA
CDERR_NOHINSTANCE = &H4
CDERR_NOHOOK = &HB
CDERR_NOTEMPLATE = &H3
CDERR_REGISTERMSGFAIL = &HC
CDERR_STRUCTSIZE = &H1
End Enum
Private Sub Class_Initialize()
mvarMaxFileSize = 256
mvarFileName = String(mvarMaxFileSize, 0)
End Sub
Public Property Let InitDir(newVal As String)
mvarInitDir = newVal
End Property
Public Property Get InitDir() As String
InitDir = mvarInitDir
End Property
Public Property Let DialogTitle(ByVal newVal As String)
mvarDialogTitle = newVal
End Property
Public Property Get DialogTitle() As String
DialogTitle = mvarDialogTitle
End Property
Public Property Let Filter(ByVal newVal As String)
Dim tmp, i As Integer
tmp = Split(newVal, "|")
mvarFilter = ""
mvarUserFilter = newVal
For i = LBound(tmp) To UBound(tmp)
mvarFilter = mvarFilter & tmp(i) & Chr(0)
Next
mvarFilter = mvarFilter & Chr(0)
End Property
Public Property Get Filter() As String
Filter = mvarUserFilter
End Property
Public Property Get Path() As String
Path = mvarPath
End Property
Public Property Get DefaultExt() As String
DefaultExt = mvarDefaultExt
End Property
Public Property Let DefaultExt(ByVal newVal As String)
mvarDefaultExt = newVal
End Property
Public Property Let FileName(ByVal newVal As String)
mvarFileName = newVal
End Property
Public Property Get FileName() As String
FileName = mvarFileName
End Property
Public Property Get FileTitle() As String
FileTitle = mvarFileTitle
End Property
Public Property Let FilterIndex(ByVal newVal As Integer)
mvarFilterIndex = newVal
End Property
Public Property Get FilterIndex() As Integer
FilterIndex = mvarFilterIndex
End Property
Public Property Let Flags(ByVal newVal As cdlFlags)
mvarFlags = newVal
End Property
Public Property Get Flags() As cdlFlags
Flags = mvarFlags
End Property
Public Property Let MaxFileSize(ByVal newVal As Integer)
mvarMaxFileSize = newVal
mvarFileName = String(newVal, 0)
End Property
Public Property Get MaxFileSize() As Integer
MaxFileSize = mvarMaxFileSize
End Property
Public Property Get LastError() As cdlError
LastError = mvarErrorCode
End Property
Public Function Browse() As Long
' Displays the Browse For Folder dialog
Dim Path As String * MAX_PATH
Dim retval As Long, bi As BROWSEINFO
bi.ulFlags = BIF_RETURNONLYFSDIRS
bi.lpszTitle = mvarDialogTitle
retval = SHBrowseForFolder(bi)
If retval Then
Call SHGetPathFromIDList(retval, Path)
mvarPath = Left(Path, InStr(Path, Chr(0)))
End If
Call CoTaskMemFree(retval)
Browse = retval
End Function
Public Function ShowOpen() As Long
' Displays the Open dialog.
' A positive return value indicates success (the user selected a file)
' A zero return indicates the user either cancelled or closed the dialog
' A negative return value indicates the API call failed
Dim retval As Long, ofn As OPENFILENAME
With ofn
.lStructSize = Len(ofn)
.Flags = mvarFlags
.lpstrDefExt = mvarDefaultExt
.lpstrFile = mvarFileName
.lpstrInitialDir = mvarInitDir
.lpstrTitle = mvarDialogTitle
.lpstrFilter = mvarFilter
.nFilterIndex = mvarFilterIndex
.lpstrFileTitle = mvarFileName
.nMaxFile = mvarMaxFileSize
.nMaxFileTitle = mvarMaxFileSize
End With
retval = GetOpenFileName(ofn)
If retval > 0 Then
Call GetComponents(ofn)
Else
mvarErrorCode = CommDlgExtendedError
End If
ShowOpen = retval
End Function
Public Function ShowSave() As Long
' Displays the Save/SaveAs dialog.
' A positive return value indicates success (the user selected a file)
' A zero return indicates the user either cancelled or closed the dialog
' A negative return value indicates the API call failed
Dim retval As Long, ofn As OPENFILENAME
With ofn
.lStructSize = Len(ofn)
.Flags = mvarFlags
.lpstrDefExt = mvarDefaultExt
.lpstrFile = mvarFileName
.lpstrInitialDir = mvarInitDir
.lpstrTitle = mvarDialogTitle
.lpstrFilter = mvarFilter
.nFilterIndex = mvarFilterIndex
.lpstrFileTitle = mvarFileName
.nMaxFile = mvarMaxFileSize
.nMaxFileTitle = mvarMaxFileSize
End With
retval = GetSaveFileName(ofn)
If retval > 0 Then
Call GetComponents(ofn)
Else
mvarErrorCode = CommDlgExtendedError
End If
ShowSave = retval
End Function
Public Function ParseFileNames() As Variant
Dim tmp, retval(), i As Integer
Dim min As Integer, max As Integer
tmp = Split(mvarFileName, Chr(0))
min = LBound(tmp): max = UBound(tmp)
If min = max Then
ReDim retval(min To min)
retval(min) = mvarFileName
Else
ReDim retval(min To max - 1)
For i = min To max - 1
retval(i) = tmp(min) & "\" & tmp(i + 1)
Next
End If
ParseFileNames = retval
End Function
Private Sub GetComponents(ofn As OPENFILENAME)
mvarFileName = Left$(ofn.lpstrFile, _
InStr(ofn.nFileOffset + 1, _
ofn.lpstrFile, _
Chr(0) & Chr(0), _
vbBinaryCompare) - 1 _
)
mvarFileTitle = Left$(ofn.lpstrFileTitle, InStr(ofn.lpstrFileTitle, Chr(0) & Chr(0)) - 1)
mvarPath = Left(mvarFileName, ofn.nFileOffset)
End Sub
Private Function Split(ByVal Str As String, ByVal Delim As String) As Variant
Dim tokens() As String, pos As Long, i As Integer
pos = InStr(1, Str, Delim, vbTextCompare)
i = 0
Do While pos > 0
ReDim Preserve tokens(0 To i)
tokens(i) = Mid$(Str, 1, pos - 1)
If tokens(i) = Delim Then tokens(i) = ""
Str = Mid$(Str, pos + Len(Delim))
i = i + 1
pos = InStr(1, Str, Delim, vbTextCompare)
Loop
If Len(Str) > 0 Then
ReDim Preserve tokens(0 To i)
tokens(i) = Str
End If
Split = tokens
End Function