VERSION 1.0 CLASS BEGIN MultiUse = -1 'True Persistable = 0 'NotPersistable DataBindingBehavior = 0 'vbNone DataSourceBehavior = 0 'vbNone MTSTransactionMode = 0 'NotAnMTSObject END Attribute VB_Name = "cFileDlg" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = True Attribute VB_PredeclaredId = False Attribute VB_Exposed = False Option Explicit '**************************************************************** '* VB file: CmnDlg.bas... VB32 wrapper for Win32 common dialog '* functions. '* created: 1997 by Ray Mercer '* modified: 8/98 by Ray Mercer (added browse for folders) '* modified: 10/21/98 by Ray Mercer (added comments) '* modified: 11/19/98 by Ray Mercer (major enhancements) '* modified: 01/28/99 by Ray Mercer (added CenterScreen()) '* modified: 12/31/99 by Ray Mercer (changed to Class Module) '* modified: 02/13/00 by Ray Mercer '* changed name to cFileDlg.cls '* simplified interface and removed extra code '* this class now supports only FileOpen and FileSave dialogs '* '* '* original functions based on code found in Bruce McKinney's book '* "Hardcore Visual Basic" '* enhancements on 11/19/98 based on code by Brad Martinez (especially '* useful comments) '* '* Copyright (C) 1997 - 2000 Ray Mercer. All rights reserved. '* Latest version can be downloaded from http://www.shrinkwrapvb.com '**************************************************************** Private Const MAX_PATH = 1024 Private Const MAX_FILE = 512 ' 'Private Type SHITEMID ' cb As Long 'Size of the ID (including cb itself) ' abID As Byte 'The item ID (variable length) 'End Type 'Private Type ITEMIDLIST ' mkid As SHITEMID 'End Type 'most of these are also in 'HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders Public Enum SPECIAL_FOLDERS 'Windows desktop virtual folder at the root of the name space vbCSIDL_DESKTOP = &H0& 'File system directory that contains the 'user's program groups (which are also file 'system directories) vbCSIDL_PROGRAMS = &H2& 'Control Panel - virtual folder containing 'icons for the control panel applications vbCSIDL_CONTROLS = &H3& 'Printers folder - virtual folder containing 'installed printers. vbCSIDL_PRINTERS = &H4& 'File system directory that serves as a 'common repository for documents (My Documents folder) vbCSIDL_PERSONAL = &H5& 'File system directory that contains the 'user's favorite Internet Explorer URLs vbCSIDL_FAVORITES = &H6& 'File system directory that corresponds to the 'user's Startup program group vbCSIDL_STARTUP = &H7& 'File system directory that contains the 'user's most recently used documents (Recent folder) vbCSIDL_RECENT = &H8& 'File system directory that contains 'Send To menu items Public Const vbCSIDL_SENDTO = &H9& 'Recycle bin file system directory containing file 'objects in the user's recycle bin. The location of 'this directory is not in the registry; it is marked 'with the hidden and system attributes to prevent the 'user from moving or deleting it. vbCSIDL_BITBUCKET = &HA& 'File system directory containing Start menu items vbCSIDL_STARTMENU = &HB& 'File system directory used to physically store 'file objects on the desktop (not to be confused 'with the desktop folder itself). vbCSIDL_DESKTOPDIRECTORY = &H10& 'My Computer - virtual folder containing everything 'on the local computer: storage devices, printers, 'and Control Panel. The folder may also contain 'mapped network drives. vbCSIDL_DRIVES = &H11& 'Network Neighborhood - virtual folder representing 'the top level of the network hierarchy vbCSIDL_NETWORK = &H12& 'File system directory containing objects that 'appear in the network neighborhood vbCSIDL_NETHOOD = &H13& 'Virtual folder containing fonts vbCSIDL_FONTS = &H14& 'File system directory that serves as a 'common repository for document templates '(ShellNew folder.) vbCSIDL_TEMPLATES = &H15& End Enum Private Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" _ (ByVal hWndOwner As Long, _ ByVal nFolder As SPECIAL_FOLDERS, _ pidl As Long) As Long 'returns NOERROR on success 'Converts an item identifier list to a file system path. 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 Const NOERROR As Long = &H0 Private Type OPENFILENAME lStructSize As Long ' Filled with UDT size hWndOwner As Long ' Tied to Owner hInstance As Long ' Ignored (used only by templates) lpstrFilter As String ' Tied to Filter lpstrCustomFilter As String ' Ignored (exercise for reader) nMaxCustFilter As Long ' Ignored (exercise for reader) nFilterIndex As Long ' Tied to FilterIndex lpstrFile As String ' Tied to FileName nMaxFile As Long ' Handled internally lpstrFileTitle As String ' Tied to FileTitle nMaxFileTitle As Long ' Handled internally lpstrInitialDir As String ' Tied to InitDir lpstrTitle As String ' Tied to DlgTitle Flags As Long ' Tied to Flags nFileOffset As Integer ' Ignored (exercise for reader) nFileExtension As Integer ' Ignored (exercise for reader) lpstrDefExt As String ' Tied to DefaultExt lCustData As Long ' Ignored (needed for hooks) lpfnHook As Long ' Ignored (good luck with hooks) lpTemplateName As Long ' Ignored (good luck with templates) End Type Private Declare Function GetOpenFileName Lib "COMDLG32" _ Alias "GetOpenFileNameA" (filestruct As OPENFILENAME) As Long Private Declare Function GetSaveFileName Lib "COMDLG32" _ Alias "GetSaveFileNameA" (filestruct As OPENFILENAME) As Long Private Declare Function GetFileTitle Lib "COMDLG32" _ Alias "GetFileTitleA" (ByVal szFile As String, _ ByVal szTitle As String, ByVal cbBuf As Integer) As Integer 'VFW "customized" File Dialogs Private Declare Function GetOpenFileNamePreview Lib "MSVFW32" _ Alias "GetOpenFileNamePreviewA" (filestruct As OPENFILENAME) As Long Private Declare Function GetSaveFileNamePreview Lib "MSVFW32" _ Alias "GetSaveFileNamePreviewA" (filestruct As OPENFILENAME) As Long Public Enum EOpenFile OFN_READONLY = &H1& OFN_OVERWRITEPROMPT = &H2& OFN_HIDEREADONLY = &H4& OFN_NOCHANGEDIR = &H8& OFN_SHOWHELP = &H10& OFN_ENABLEHOOK = &H20& OFN_ENABLETEMPLATE = &H40& OFN_ENABLETEMPLATEHANDLE = &H80& OFN_NOVALIDATE = &H100& OFN_ALLOWMULTISELECT = &H200& OFN_EXTENSIONDIFFERENT = &H400& OFN_PATHMUSTEXIST = &H800& OFN_FILEMUSTEXIST = &H1000& OFN_CREATEPROMPT = &H2000& OFN_SHAREAWARE = &H4000& OFN_NOREADONLYRETURN = &H8000& OFN_NOTESTFILECREATE = &H10000 OFN_NONETWORKBUTTON = &H20000 OFN_NOLONGNAMES = &H40000 OFN_EXPLORER = &H80000 OFN_NODEREFERENCELINKS = &H100000 OFN_LONGNAMES = &H200000 End Enum Private Declare Function CommDlgExtendedError Lib "COMDLG32" () As Long Public Enum EDialogError CDERR_DIALOGFAILURE = &HFFFF& CDERR_GENERALCODES = &H0& CDERR_STRUCTSIZE = &H1& CDERR_INITIALIZATION = &H2& CDERR_NOTEMPLATE = &H3& CDERR_NOHINSTANCE = &H4& CDERR_LOADSTRFAILURE = &H5& CDERR_FINDRESFAILURE = &H6& CDERR_LOADRESFAILURE = &H7& CDERR_LOCKRESFAILURE = &H8& CDERR_MEMALLOCFAILURE = &H9& CDERR_MEMLOCKFAILURE = &HA& CDERR_NOHOOK = &HB& CDERR_REGISTERMSGFAIL = &HC& PDERR_PRINTERCODES = &H1000& PDERR_SETUPFAILURE = &H1001& PDERR_PARSEFAILURE = &H1002& PDERR_RETDEFFAILURE = &H1003& PDERR_LOADDRVFAILURE = &H1004& PDERR_GETDEVMODEFAIL = &H1005& PDERR_INITFAILURE = &H1006& PDERR_NODEVICES = &H1007& PDERR_NODEFAULTPRN = &H1008& PDERR_DNDMMISMATCH = &H1009& PDERR_CREATEICFAILURE = &H100A& PDERR_PRINTERNOTFOUND = &H100B& PDERR_DEFAULTDIFFERENT = &H100C& CFERR_CHOOSEFONTCODES = &H2000& CFERR_NOFONTS = &H2001& CFERR_MAXLESSTHANMIN = &H2002& FNERR_FILENAMECODES = &H3000& FNERR_SUBCLASSFAILURE = &H3001& FNERR_INVALIDFILENAME = &H3002& FNERR_BUFFERTOOSMALL = &H3003& CCERR_CHOOSECOLORCODES = &H5000& End Enum Private Const sEmpty As String = "" 'Class member variables Private m_FileMustExist As Boolean Private m_MultiSelect As Boolean Private m_ReadOnly As Boolean 'read only Private m_HideReadOnly As Boolean Private m_Filter As String Private m_FilterIndex As Long Private m_InitDir As String Private m_DlgTitle As String Private m_DefaultExt As String Private m_Flags As Long Private m_OverwritePrompt As Boolean Private m_hWnd As Long Private Sub Class_Initialize() 'Initialize default values m_hWnd = -1& m_FileMustExist = True m_MultiSelect = False m_HideReadOnly = True m_DlgTitle = App.title m_OverwritePrompt = True m_InitDir = GetSpecialFolderLocation(vbCSIDL_PERSONAL) 'default to My Documents folder End Sub Property Get OwnerHwnd() As Long OwnerHwnd = m_hWnd End Property Property Let OwnerHwnd(ByVal vHwnd As Long) m_hWnd = vHwnd End Property Property Get FileMustExist() As Boolean FileMustExist = m_FileMustExist End Property Property Let FileMustExist(ByVal vNewValue As Boolean) m_FileMustExist = vNewValue End Property Property Get MultiSelect() As Boolean MultiSelect = m_MultiSelect End Property Property Let MultiSelect(ByVal vNewValue As Boolean) m_MultiSelect = vNewValue End Property Property Get ReadOnly() As Boolean ReadOnly = m_ReadOnly End Property Property Get HideReadOnly() As Boolean HideReadOnly = m_HideReadOnly End Property Property Let HideReadOnly(ByVal vNewValue As Boolean) m_HideReadOnly = vNewValue End Property Property Get Filter() As String Filter = m_Filter End Property Property Let Filter(ByVal vFilterString As String) m_Filter = vFilterString End Property Property Get FilterIndex() As Long FilterIndex = m_FilterIndex End Property Property Let FilterIndex(ByVal vIndex As Long) m_FilterIndex = vIndex End Property Property Get InitDirectory() As String InitDirectory = m_InitDir End Property Property Let InitDirectory(ByVal DirPath As String) m_InitDir = DirPath End Property Property Let InitDirectorySpecial(ByVal SpecialDirectory As SPECIAL_FOLDERS) m_InitDir = GetSpecialFolderLocation(SpecialDirectory) End Property Property Get DlgTitle() As String DlgTitle = m_DlgTitle End Property Property Let DlgTitle(ByVal title As String) m_DlgTitle = title End Property Property Get DefaultExt() As String DefaultExt = m_DefaultExt End Property Property Let DefaultExt(ByVal fileExt As String) m_DefaultExt = fileExt End Property Property Get Flags() As Long Flags = m_Flags End Property Property Let Flags(ByVal vFlags As EOpenFile) m_Flags = vFlags End Property Property Get OverwritePrompt() As Boolean OverwritePrompt = m_OverwritePrompt End Property Property Let OverwritePrompt(ByVal vShowPrompt As Boolean) m_OverwritePrompt = vShowPrompt End Property Public Function VBGetOpenFileName(filename As String, _ Optional FileTitle As String) As Boolean Dim opfile As OPENFILENAME Dim s As String Dim afFlags As Long Dim ch As String Dim i As Integer With opfile .lStructSize = Len(opfile) ' Add in specific flags and strip out non-VB flags .Flags = (-m_FileMustExist * OFN_FILEMUSTEXIST) Or _ (-m_MultiSelect * OFN_ALLOWMULTISELECT) Or _ (-m_ReadOnly * OFN_READONLY) Or _ (-m_HideReadOnly * OFN_HIDEREADONLY) Or _ (m_Flags And CLng(Not (OFN_ENABLEHOOK Or _ OFN_ENABLETEMPLATE))) ' Owner can take handle of owning window If m_hWnd <> -1 Then .hWndOwner = m_hWnd ' InitDir can take initial directory string .lpstrInitialDir = m_InitDir ' DefaultExt can take default extension .lpstrDefExt = m_DefaultExt ' DlgTitle can take dialog box title .lpstrTitle = m_DlgTitle ' To make Windows-style filter, replace | and : with nulls For i = 1 To Len(Filter) ch = Mid$(Filter, i, 1) If ch = "|" Or ch = ":" Then s = s & vbNullChar Else s = s & ch End If Next ' Put double null at end s = s & vbNullChar & vbNullChar .lpstrFilter = s .nFilterIndex = m_FilterIndex ' Pad file and file title buffers to maximum path s = filename & String$(MAX_PATH - Len(filename), 0) .lpstrFile = s .nMaxFile = MAX_PATH s = FileTitle & String$(MAX_FILE - Len(FileTitle), 0) .lpstrFileTitle = s .nMaxFileTitle = MAX_FILE ' All other fields set to zero If GetOpenFileName(opfile) Then VBGetOpenFileName = True filename = left$(.lpstrFile, InStr(.lpstrFile, vbNullChar) - 1) FileTitle = left$(.lpstrFileTitle, InStr(.lpstrFileTitle, vbNullChar) - 1) m_Flags = .Flags ' Return the filter index m_FilterIndex = .nFilterIndex ' Look up the filter the user selected and return that m_Filter = FilterLookup(.lpstrFilter, m_FilterIndex) If (.Flags And OFN_READONLY) Then m_ReadOnly = True 'save directory as init directory for user m_InitDir = .lpstrFile Else VBGetOpenFileName = False filename = vbNullChar FileTitle = vbNullChar Flags = 0 FilterIndex = -1 Filter = vbNullChar End If End With End Function Public Function VBGetOpenFileNamePreview(filename As String, _ Optional FileTitle As String) As Boolean Dim opfile As OPENFILENAME Dim s As String Dim afFlags As Long Dim ch As String Dim i As Integer With opfile .lStructSize = Len(opfile) ' Add in specific flags and strip out non-VB flags .Flags = (-m_FileMustExist * OFN_FILEMUSTEXIST) Or _ (-m_MultiSelect * OFN_ALLOWMULTISELECT) Or _ (-m_ReadOnly * OFN_READONLY) Or _ (-m_HideReadOnly * OFN_HIDEREADONLY) Or _ (m_Flags And CLng(Not (OFN_ENABLEHOOK Or _ OFN_ENABLETEMPLATE))) ' Owner can take handle of owning window If m_hWnd <> -1 Then .hWndOwner = m_hWnd ' InitDir can take initial directory string .lpstrInitialDir = m_InitDir ' DefaultExt can take default extension .lpstrDefExt = m_DefaultExt ' DlgTitle can take dialog box title .lpstrTitle = m_DlgTitle ' To make Windows-style filter, replace | and : with nulls For i = 1 To Len(Filter) ch = Mid$(Filter, i, 1) If ch = "|" Or ch = ":" Then s = s & vbNullChar Else s = s & ch End If Next ' Put double null at end s = s & vbNullChar & vbNullChar .lpstrFilter = s .nFilterIndex = m_FilterIndex ' Pad file and file title buffers to maximum path s = filename & String$(MAX_PATH - Len(filename), 0) .lpstrFile = s .nMaxFile = MAX_PATH s = FileTitle & String$(MAX_FILE - Len(FileTitle), 0) .lpstrFileTitle = s .nMaxFileTitle = MAX_FILE ' All other fields set to zero If GetOpenFileNamePreview(opfile) Then VBGetOpenFileNamePreview = True filename = left$(.lpstrFile, InStr(.lpstrFile, vbNullChar) - 1) FileTitle = left$(.lpstrFileTitle, InStr(.lpstrFileTitle, vbNullChar) - 1) m_Flags = .Flags ' Return the filter index m_FilterIndex = .nFilterIndex ' Look up the filter the user selected and return that m_Filter = FilterLookup(.lpstrFilter, m_FilterIndex) If (.Flags And OFN_READONLY) Then m_ReadOnly = True 'save directory as init directory for user m_InitDir = .lpstrFile Else VBGetOpenFileNamePreview = False filename = vbNullChar FileTitle = vbNullChar Flags = 0 FilterIndex = -1 Filter = vbNullChar End If End With End Function Public Function VBGetSaveFileName(filename As String, _ Optional FileTitle As String) As Boolean Dim opfile As OPENFILENAME, s As String With opfile .lStructSize = Len(opfile) ' Add in specific flags and strip out non-VB flags .Flags = (-m_OverwritePrompt * OFN_OVERWRITEPROMPT) Or _ OFN_HIDEREADONLY Or _ (m_Flags And CLng(Not (OFN_ENABLEHOOK Or _ OFN_ENABLETEMPLATE))) ' Owner can take handle of owning window If m_hWnd <> -1 Then .hWndOwner = m_hWnd ' InitDir can take initial directory string .lpstrInitialDir = m_InitDir ' DefaultExt can take default extension .lpstrDefExt = m_DefaultExt ' DlgTitle can take dialog box title .lpstrTitle = m_DlgTitle ' Make new filter with bars (|) replacing nulls and double null at end Dim ch As String, i As Integer For i = 1 To Len(Filter) ch = Mid$(Filter, i, 1) If ch = "|" Or ch = ":" Then s = s & vbNullChar Else s = s & ch End If Next ' Put double null at end s = s & vbNullChar & vbNullChar .lpstrFilter = s .nFilterIndex = m_FilterIndex ' Pad file and file title buffers to maximum path s = filename & String$(MAX_PATH - Len(filename), 0) .lpstrFile = s .nMaxFile = MAX_PATH s = FileTitle & String$(MAX_FILE - Len(FileTitle), 0) .lpstrFileTitle = s .nMaxFileTitle = MAX_FILE ' All other fields zero If GetSaveFileName(opfile) Then VBGetSaveFileName = True filename = left$(.lpstrFile, InStr(.lpstrFile, vbNullChar) - 1) FileTitle = left$(.lpstrFileTitle, InStr(.lpstrFileTitle, vbNullChar) - 1) m_Flags = .Flags ' Return the filter index m_FilterIndex = .nFilterIndex ' Look up the filter the user selected and return that m_Filter = FilterLookup(.lpstrFilter, FilterIndex) 'save directory as init directory for user m_InitDir = .lpstrFile Else VBGetSaveFileName = False filename = vbNullChar FileTitle = vbNullChar m_Flags = 0 m_FilterIndex = 0 m_Filter = vbNullChar End If End With End Function Private Function FilterLookup(ByVal sFilters As String, ByVal iCur As Long) As String Dim iStart As Long Dim iEnd As Long Dim s As String iStart = 1 If sFilters = vbNullChar Then Exit Function Do ' Cut out both parts marked by null character iEnd = InStr(iStart, sFilters, vbNullChar) If iEnd = 0 Then Exit Function iEnd = InStr(iEnd + 1, sFilters, vbNullChar) If iEnd Then s = Mid$(sFilters, iStart, iEnd - iStart) Else s = Mid$(sFilters, iStart) End If iStart = iEnd + 1 If iCur = 1 Then FilterLookup = s Exit Function End If iCur = iCur - 1 Loop While iCur End Function Private Function StrZToStr(s As String) As String Dim TempString As String TempString = left$(s, InStr(s, vbNullChar) - 1) If TempString = "" Then 'if VB string is accidently passed in there will be no NULL 'so just pass back the original string in that case StrZToStr = s Else StrZToStr = TempString End If End Function 'This fuction is courtesy of Randy Birch and VBNet 'however I changed it a bit to fit my class Private Function GetSpecialFolderLocation(CSIDL As SPECIAL_FOLDERS) As String Dim sPath As String Dim pidl As Long 'fill the idl structure with the specified folder item If SHGetSpecialFolderLocation(m_hWnd, CSIDL, pidl) = NOERROR Then 'if the pidl is returned, initialize 'and get the path from the id list sPath = Space$(MAX_PATH) If SHGetPathFromIDList(ByVal pidl, ByVal sPath) Then 'free the pidl and return the path Call CoTaskMemFree(ByVal VarPtr(pidl)) GetSpecialFolderLocation = left(sPath, InStr(sPath, Chr$(0)) - 1) End If End If End Function ' Here are a couple of utility functions often needed when file dialogs are used ' Test file existence with error trapping Public Function ExistFile(ByVal sSpec As String) As Boolean On Error Resume Next Call fileLen(sSpec) ExistFile = (Err = 0) End Function 'Get FileTitle (filename without path) from any full path Public Function VBGetFileTitle(sFile As String) As String Dim sFileTitle As String, cFileTitle As Integer cFileTitle = MAX_PATH sFileTitle = String$(MAX_PATH, 0) cFileTitle = GetFileTitle(sFile, sFileTitle, MAX_PATH) If cFileTitle Then VBGetFileTitle = "" Else VBGetFileTitle = left$(sFileTitle, InStr(sFileTitle, vbNullChar) - 1) End If End Function