www.pudn.com > shrinkVideo.rar > CmnDlg.bas
Attribute VB_Name = "mCmnDlg"
'****************************************************************
'* 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)
'* last modified: 10/21/98 by Ray Mercer (added comments)
'*
'*
'* original functions based on code found in Bruce McKinney's book
'* "Hardcore Visual Basic"
'*
'* Copyright (c) 1997,1998 Ray Mercer. All rights reserved.
'****************************************************************
Option Private Module
Option Explicit
Private Const MAX_PATH = 1024
Private Const MAX_FILE = 512
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 Declare Function SHBrowseForFolder Lib "shell32" (lpbi As TBrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Type TBrowseInfo
hwndOwner 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 CSIDL_DRIVES As Long = &H11&
Private Const BIF_RETURNONLYFSDIRS As Long = &H1& '// For finding a folder to start document searching
Private Const BIF_DONTGOBELOWDOMAIN As Long = &H2& '// For starting the Find Computer
Private Const BIF_STATUSTEXT As Long = &H4& '
Private Const BIF_RETURNFSANCESTORS = &H8& '
Private Const BIF_BROWSEFORCOMPUTER = &H1000& '// Browsing for Computers.
Private Const BIF_BROWSEFORPRINTER = &H2000& '// Browsing for Printers
Private Const BIF_BROWSEINCLUDEFILES = &H4000 '// Browsing for Everything
Private Const sEmpty As String = ""
Public Function VBGetOpenFileName(FileName As String, _
Optional FileTitle As String, _
Optional FileMustExist As Boolean = True, _
Optional MultiSelect As Boolean = False, _
Optional ReadOnly As Boolean = False, _
Optional HideReadOnly As Boolean = False, _
Optional filter As String = "All (*.*)| *.*", _
Optional FilterIndex As Long = 1, _
Optional InitDir As String, _
Optional DlgTitle As String, _
Optional DefaultExt As String, _
Optional Owner As Long = -1, _
Optional Flags As Long = 0) As Boolean
Dim opfile As OPENFILENAME, s As String, afFlags As Long
With opfile
.lStructSize = Len(opfile)
' Add in specific flags and strip out non-VB flags
.Flags = (-FileMustExist * OFN_FILEMUSTEXIST) Or _
(-MultiSelect * OFN_ALLOWMULTISELECT) Or _
(-ReadOnly * OFN_READONLY) Or _
(-HideReadOnly * OFN_HIDEREADONLY) Or _
(Flags And CLng(Not (OFN_ENABLEHOOK Or _
OFN_ENABLETEMPLATE)))
' Owner can take handle of owning window
If Owner <> -1 Then .hwndOwner = Owner
' InitDir can take initial directory string
.lpstrInitialDir = InitDir
' DefaultExt can take default extension
.lpstrDefExt = DefaultExt
' DlgTitle can take dialog box title
.lpstrTitle = DlgTitle
' To make Windows-style filter, replace | and : with nulls
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 = 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)
Flags = .Flags
' Return the filter index
FilterIndex = .nFilterIndex
' Look up the filter the user selected and return that
filter = FilterLookup(.lpstrFilter, FilterIndex)
If (.Flags And OFN_READONLY) Then ReadOnly = True
Else
VBGetOpenFileName = 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, _
Optional OverWritePrompt As Boolean = True, _
Optional filter As String = "All (*.*)| *.*", _
Optional FilterIndex As Long = 1, _
Optional InitDir As String, _
Optional DlgTitle As String, _
Optional DefaultExt As String, _
Optional Owner As Long = -1, _
Optional Flags As Long) 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 = (-OverWritePrompt * OFN_OVERWRITEPROMPT) Or _
OFN_HIDEREADONLY Or _
(Flags And CLng(Not (OFN_ENABLEHOOK Or _
OFN_ENABLETEMPLATE)))
' Owner can take handle of owning window
If Owner <> -1 Then .hwndOwner = Owner
' InitDir can take initial directory string
.lpstrInitialDir = InitDir
' DefaultExt can take default extension
.lpstrDefExt = DefaultExt
' DlgTitle can take dialog box title
.lpstrTitle = 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 = 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)
Flags = .Flags
' Return the filter index
FilterIndex = .nFilterIndex
' Look up the filter the user selected and return that
filter = FilterLookup(.lpstrFilter, FilterIndex)
Else
VBGetSaveFileName = False
FileName = vbNullChar
FileTitle = vbNullChar
Flags = 0
FilterIndex = 0
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, iEnd As Long, 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
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
Public Function VBGetOpenFileNamePreview(FileName As String, _
Optional FileTitle As String, _
Optional FileMustExist As Boolean = True, _
Optional MultiSelect As Boolean = False, _
Optional ReadOnly As Boolean = False, _
Optional HideReadOnly As Boolean = False, _
Optional filter As String = "All (*.*)| *.*", _
Optional FilterIndex As Long = 1, _
Optional InitDir As String, _
Optional DlgTitle As String, _
Optional DefaultExt As String, _
Optional Owner As Long = -1, _
Optional Flags As Long = 0) As Boolean
Dim opfile As OPENFILENAME, s As String, afFlags As Long
With opfile
.lStructSize = Len(opfile)
' Add in specific flags and strip out non-VB flags
.Flags = (-FileMustExist * OFN_FILEMUSTEXIST) Or _
(-MultiSelect * OFN_ALLOWMULTISELECT) Or _
(-ReadOnly * OFN_READONLY) Or _
(-HideReadOnly * OFN_HIDEREADONLY) Or _
(Flags And CLng(Not (OFN_ENABLEHOOK Or _
OFN_ENABLETEMPLATE)))
' Owner can take handle of owning window
If Owner <> -1 Then .hwndOwner = Owner
' InitDir can take initial directory string
.lpstrInitialDir = InitDir
' DefaultExt can take default extension
.lpstrDefExt = DefaultExt
' DlgTitle can take dialog box title
.lpstrTitle = DlgTitle
' To make Windows-style filter, replace | and : with nulls
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 = 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)
Flags = .Flags
' Return the filter index
FilterIndex = .nFilterIndex
' Look up the filter the user selected and return that
filter = FilterLookup(.lpstrFilter, FilterIndex)
If (.Flags And OFN_READONLY) Then ReadOnly = True
Else
VBGetOpenFileNamePreview = False
FileName = vbNullChar
FileTitle = vbNullChar
Flags = 0
FilterIndex = -1
filter = vbNullChar
End If
End With
End Function
Public Function VBGetSaveFileNamePreview(FileName As String, _
Optional FileTitle As String, _
Optional FileMustExist As Boolean = True, _
Optional MultiSelect As Boolean = False, _
Optional ReadOnly As Boolean = False, _
Optional HideReadOnly As Boolean = False, _
Optional filter As String = "All (*.*)| *.*", _
Optional FilterIndex As Long = 1, _
Optional InitDir As String, _
Optional DlgTitle As String, _
Optional DefaultExt As String, _
Optional Owner As Long = -1, _
Optional Flags As Long = 0) As Boolean
Dim opfile As OPENFILENAME, s As String, afFlags As Long
With opfile
.lStructSize = Len(opfile)
' Add in specific flags and strip out non-VB flags
.Flags = (-FileMustExist * OFN_FILEMUSTEXIST) Or _
(-MultiSelect * OFN_ALLOWMULTISELECT) Or _
(-ReadOnly * OFN_READONLY) Or _
(-HideReadOnly * OFN_HIDEREADONLY) Or _
(Flags And CLng(Not (OFN_ENABLEHOOK Or _
OFN_ENABLETEMPLATE)))
' Owner can take handle of owning window
If Owner <> -1 Then .hwndOwner = Owner
' InitDir can take initial directory string
.lpstrInitialDir = InitDir
' DefaultExt can take default extension
.lpstrDefExt = DefaultExt
' DlgTitle can take dialog box title
.lpstrTitle = DlgTitle
' To make Windows-style filter, replace | and : with nulls
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 = 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 GetSaveFileNamePreview(opfile) Then
VBGetSaveFileNamePreview = True
FileName = Left$(.lpstrFile, InStr(.lpstrFile, vbNullChar) - 1)
FileTitle = Left$(.lpstrFileTitle, InStr(.lpstrFileTitle, vbNullChar) - 1)
Flags = .Flags
' Return the filter index
FilterIndex = .nFilterIndex
' Look up the filter the user selected and return that
filter = FilterLookup(.lpstrFilter, FilterIndex)
If (.Flags And OFN_READONLY) Then ReadOnly = True
Else
VBGetSaveFileNamePreview = False
FileName = vbNullChar
FileTitle = vbNullChar
Flags = 0
FilterIndex = -1
filter = vbNullChar
End If
End With
End Function
Private Function StrZToStr(s As String) As String
' Dim startp As Integer, endp As Integer
' Dim newString As String
'
' startp = 1
' Do While (Asc(Mid$(s, startp, 1)) <> 0)
' endp = InStr(startp, s, vbNullChar)
' If endp = 0 Then StrZToStr = s: Exit Function 'handle VB strings
' newString = newString & Mid$(s, startp, endp - startp)
' startp = endp + 1
' Loop
' StrZToStr = newString
'different algorithm
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
' Test file existence with error trapping
Public Function ExistFile(sSpec As String) As Boolean
On Error Resume Next
Call FileLen(sSpec)
ExistFile = (Err = 0)
End Function