Common Dialog without Form

[jkejke]

is it possible to use the Common dialog without a form--

Never done--question asked by another programmer

Thanks--

 

[woyler]

You can use the API Paste this in a module:

Option Explicit
Private Const MAX_PATH = 260
Private Const SHGFI_DISPLAYNAME = &H200
Private Const SHGFI_EXETYPE = &H2000
Private Const SHGFI_SYSICONINDEX = &H4000 'system icon index
Private Const SHGFI_LARGEICON = &H0 'large icon
Private Const SHGFI_SMALLICON = &H1 'small icon
Private Const SHGFI_SHELLICONSIZE = &H4
Private Const SHGFI_TYPENAME = &H400
Private Const OFN_READONLY = &H1
Private Const OFN_OVERWRITEPROMPT = &H2
Private Const OFN_HIDEREADONLY = &H4
Private Const OFN_NOCHANGEDIR = &H8
Private Const OFN_SHOWHELP = &H10
Private Const OFN_ENABLEHOOK = &H20
Private Const OFN_ENABLETEMPLATE = &H40
Private Const OFN_ENABLETEMPLATEHANDLE = &H80
Private Const OFN_NOVALIDATE = &H100
Private Const OFN_ALLOWMULTISELECT = &H200
Private Const OFN_EXTENSIONDIFFERENT = &H400
Private Const OFN_PATHMUSTEXIST = &H800
Private Const OFN_FILEMUSTEXIST = &H1000
Private Const OFN_CREATEPROMPT = &H2000
Private Const OFN_SHAREAWARE = &H4000
Private Const OFN_NOREADONLYRETURN = &H8000
Private Const OFN_NOTESTFILECREATE = &H10000
Private Const OFN_NONETWORKBUTTON = &H20000
Private Const OFN_NOLONGNAMES = &H40000 'force no long names for 4.x modules
Private Const OFN_EXPLORER = &H80000 'new look commdlg
Private Const OFN_NODEREFERENCELINKS = &H100000
Private Const OFN_LONGNAMES = &H200000 'force long names for 3.x modules

Private Const OFN_SHAREFALLTHROUGH = 2
Private Const OFN_SHARENOWARN = 1
Private Const OFN_SHAREWARN = 0
Private Const BASIC_SHGFI_FLAGS = SHGFI_TYPENAME Or SHGFI_SHELLICONSIZE Or SHGFI_DISPLAYNAME Or SHGFI_EXETYPE
Private Const BOLD_FONTTYPE = &H100
Private Const CF_ENABLETEMPLATE = &H10&
Private Const CF_ENABLEHOOK = &H8&
Private Const CF_APPLY = &H200&
Private Const CF_SCREENFONTS = &H1
Private Const CF_INITTOLOGFONTSTRUCT = &H40&
Private Const CF_EFFECTS = &H100&
Private Const CF_PALETTE = 9
Private Const LF_FACESIZE = 32
Private Const LF_FULLFACESIZE = 64
Private Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName(LF_FACESIZE) As Byte
End Type
Private Type ChooseColor
lStructSize As Long
hwndOwner As Long
hInstance As Long
rgbResult As Long
lpCustColors As String
flags As Long
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Private Type ChooseFont
lStructSize As Long
hwndOwner As Long
hdc As Long
lpLogFont As Long
iPointSize As Long
flags As Long
rgbColors As Long
lCustData As Long
lpfnHook As Long
lpTemplateName As String
hInstance As Long
lpszStyle As String
nFontType As Integer
MISSING_ALIGNMENT As Integer
nSizeMin As Long
nSizeMax As Long
End Type
Private Type BrowseInfo
hwndOwner As Long
pIDLRoot As Long
pszDisplayName As Long
lpszTitle As Long
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type
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 SHFILEINFO
hIcon As Long
iIcon As Long
dwAttributes As Long
szDisplayName As String * 260
szTypeName As String * 80
End Type

Private Declare Function ChooseColor Lib "comdlg32.dll" Alias "ChooseColorA" (pChoosecolor As ChooseColor) As Long
Private Declare Function ChooseFont Lib "comdlg32.dll" Alias "ChooseFontA" (pChoosefont As ChooseFont) As Long
Private Declare Function SHGetFileInfo Lib "shell32.dll" Alias "SHGetFileInfoA" (ByVal pszPath As String, ByVal dwFileAttributes As Long, psfi As SHFILEINFO, ByVal cbSizeFileInfo As Long, ByVal uFlags As Long) As Long
Private Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Private Declare Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" (lpvDest As Any, ByVal lpvSource As String, ByVal cbCopy As Long)
Private shinfo As SHFILEINFO

Public hwndOwner As Long
Public Filter As String
Public OpenDialogTitle As String
Public SaveDialogTitle As String
Public FolderDialogTitle As String
Public AllowMultiSelect As Boolean
Public PathMustExist As Boolean
Public FileMustExist As Boolean
Public NoChangeDir As Boolean
Public ReadOnly As Boolean
Public ShowDirsOnly As Boolean
Dim bFileCleared As Boolean
Dim Files() As String

Function ShowFont(fntDefault As StdFont, nColor As Long) As StdFont
Dim lFlags As Long, lg As LOGFONT, cf As ChooseFont
Set ShowFont = New StdFont
lFlags = lFlags Or CF_SCREENFONTS
lFlags = (lFlags Or CF_INITTOLOGFONTSTRUCT) And Not (CF_APPLY Or CF_ENABLEHOOK Or CF_ENABLETEMPLATE)
lFlags = lFlags Or CF_EFFECTS
lg.lfHeight = -(fntDefault.Size * ((1440 / 72) / Screen.TwipsPerPixelY))
lg.lfWeight = fntDefault.Weight
lg.lfItalic = fntDefault.Italic
lg.lfUnderline = fntDefault.Underline
lg.lfStrikeOut = fntDefault.Strikethrough
StrToBytes lg.lfFaceName, fntDefault.Name

cf.hInstance = App.hInstance
cf.hwndOwner = hwndOwner
cf.lpLogFont = VarPtr(lg)
cf.iPointSize = fntDefault.Size * 10
cf.flags = lFlags
cf.rgbColors = nColor
cf.lStructSize = Len(cf)
If ChooseFont(cf) Then
lFlags = cf.flags
ShowFont.Bold = cf.nFontType And BOLD_FONTTYPE
ShowFont.Italic = lg.lfItalic
ShowFont.Strikethrough = lg.lfStrikeOut
ShowFont.Underline = lg.lfUnderline
ShowFont.Weight = lg.lfWeight
ShowFont.Size = cf.iPointSize / 10
ShowFont.Name = BytesToStr(lg.lfFaceName)
nColor = cf.rgbColors
End If
End Function
Function ShowColor() As Long
Dim cd As ChooseColor
cd.lStructSize = LenB(cd)
cd.hwndOwner = hwndOwner
cd.hInstance = App.hInstance
cd.lpCustColors = String(8 * 16, 0)
If ChooseColor(cd) Then
ShowColor = cd.rgbResult
Else
ShowColor = -1
End If
End Function
Function ShowFolder() As String
Dim lRes As Long
Dim sTemp As String
Dim iPos As Integer
Dim bi As BrowseInfo
With bi
.hwndOwner = hwndOwner
.lpszTitle = lstrcat(FolderDialogTitle, "&quot
.ulFlags = Abs(ShowDirsOnly)
End With
lRes = SHBrowseForFolder(bi)
If lRes Then
sTemp = String(MAX_PATH, vbNullChar)
SHGetPathFromIDList lRes, sTemp
CoTaskMemFree lRes
iPos = InStr(sTemp, vbNullChar)
If iPos Then sTemp = Left(sTemp, iPos - 1)
End If
ShowFolder = sTemp
End Function
Function ShowOpen() As Boolean
Dim OFN As OPENFILENAME
Dim sFilter As String
Dim nRes As Long
sFilter = Filter
ReplaceChar sFilter, "|", vbNullChar
OFN.hInstance = App.hInstance
OFN.hwndOwner = hwndOwner
OFN.lpstrFile = String(MAX_PATH, vbNullChar)
OFN.lpstrTitle = OpenDialogTitle
OFN.lpstrFilter = sFilter
OFN.flags = GetFlags
OFN.nMaxFile = MAX_PATH
OFN.lStructSize = LenB(OFN)
nRes = GetOpenFileName(OFN)
ShowOpen = nRes
AddFiles OFN.lpstrFile
End Function
Function ShowSave() As String
Dim OFN As OPENFILENAME
Dim sFilter As String
Dim nRes As Long
sFilter = Filter
ReplaceChar sFilter, "|", vbNullChar
OFN.hInstance = App.hInstance
OFN.hwndOwner = hwndOwner
OFN.lpstrFile = String(MAX_PATH, vbNullChar)
OFN.lpstrFilter = sFilter
OFN.flags = GetFlags
OFN.lpstrTitle = SaveDialogTitle
OFN.nMaxFile = MAX_PATH
OFN.lStructSize = LenB(OFN)
nRes = GetSaveFileName(OFN)
If nRes Then ShowSave = TrimNull(OFN.lpstrFile) Else ShowSave = ""
End Function
'Misc Functions
Private Sub StrToBytes(ab() As Byte, s As String)
If GetCount(ab) < 0 Then
ab = StrConv(s, vbFromUnicode)
Else
Dim cab As Long
cab = UBound(ab) - LBound(ab) + 1
If Len(s) < cab Then s = s & String$(cab - Len(s), 0)
CopyMem ab(LBound(ab)), s, cab
End If
End Sub
Private Function TrimNull(ByVal sData As String) As String
Dim nPos As Long
nPos = InStr(sData, vbNullChar)
If nPos Then TrimNull = Left(sData, nPos - 1)
End Function
Private Function BytesToStr(ab() As Byte) As String
BytesToStr = StrConv(ab, vbUnicode)
End Function
Private Function GetCount(arr) As Integer
On Error Resume Next
Dim nCount As Integer
nCount = UBound(arr)
If Err Then
Err.Clear
GetCount = -1
Else
GetCount = nCount
End If
End Function
Private Sub ReplaceChar(sData As String, ByVal sFrom As String, ByVal sTo As String)
Dim sTemp As String
Dim I As Long
For I = 1 To Len(sData)
If Mid(sData, I, 1) = sFrom Then Mid(sData, I, 1) = sTo
Next I
End Sub
Private Function GetFlags() As Long
Dim nFlags As Long
nFlags = OFN_EXPLORER 'new 32bit looking dialog
AllowMultiSelect = True
If AllowMultiSelect Then nFlags = nFlags Or OFN_ALLOWMULTISELECT
If PathMustExist Then nFlags = nFlags Or OFN_PATHMUSTEXIST
If FileMustExist Then nFlags = nFlags Or OFN_FILEMUSTEXIST
If NoChangeDir Then nFlags = nFlags Or OFN_NOCHANGEDIR
If ReadOnly Then nFlags = nFlags Or OFN_READONLY
GetFlags = nFlags
End Function
Function GetFileTitle(ByVal FileName As String) As String
Dim shinfo As SHFILEINFO
Dim sTemp As String
SHGetFileInfo FileName, 0, shinfo, LenB(shinfo), &H200
sTemp = shinfo.szDisplayName
If InStr(sTemp, vbNullChar) Then sTemp = Left(sTemp, InStr(sTemp, vbNullChar) - 1)
GetFileTitle = sTemp
End Function
Function GetFileIcon(ByVal FileName As String) As Long
Dim shinfo As SHFILEINFO
Dim hIcon As String
hIcon = SHGetFileInfo(FileName, 0&, shinfo, LenB(shinfo), SHGFI_SMALLICON)
GetFileIcon = hIcon
End Function
Public Property Get FileCount() As Long
FileCount = GetFileCount() + 1
End Property
Public Property Get File(ByVal Index As Long) As String
File = Files(Index)
End Property

Private Function AddFiles(ByVal Data As String)
Dim sData As String, sTemp As String
Dim sDir As String
sData = Data
sTemp = TrimNull(Data)
ClearFiles
If Mid(sData, Len(sTemp) + 2, 1) <> vbNullChar Then
sDir = sTemp
If Right(sDir, 1) <> &quot;\&quot; Then sDir = sDir + &quot;\&quot;
sData = Right(sData, Len(Data) - Len(sTemp) - 1)
sTemp = TrimNull(sData)
Do While sTemp <> &quot;&quot;
Files(AddFile()) = sDir + sTemp
sData = Right(sData, Len(sData) - Len(sTemp) - 1)
sTemp = TrimNull(sData)
Loop
Else
Files(AddFile()) = sTemp
End If
End Function
Private Function GetFileCount() As Long
On Error Resume Next
Dim nCount As Long
nCount = UBound(Files)
If Err Or bFileCleared Then
Err.Clear
GetFileCount = -1
ElseIf Not bFileCleared Then
GetFileCount = nCount
End If
End Function
Private Function AddFile() As Long
Dim nCount As Long
nCount = GetFileCount + 1
ReDim Preserve Files(nCount) As String
AddFile = nCount
bFileCleared = False
End Function
Private Sub RemoveFile(ByVal nIndex As Long)
Dim I As Long
For I = nIndex + 1 To GetFileCount
Files(I - 1) = Files(I)
Next I
If GetFileCount > 0 Then
ReDim Preserve Files(GetFileCount - 1) As String
Else
ReDim Files(0) As String
bFileCleared = True
End If
End Sub
Private Sub ClearFiles()
ReDim Files(0) As String
bFileCleared = True
End Sub
Private Function FileExist(ByVal sFile As String, Optional ByVal bCaseSensitive As Boolean = False) As Boolean
Dim I As Long
For I = 0 To GetFileCount
If bCaseSensitive Then
If Files(I) = sFile Then
FileExist = True
Exit Function
End If
Else
If LCase(Files(I)) = LCase(sFile) Then
FileExist = True
Exit Function
End If
End If
Next I
End Function
Private Function FileIndex(ByVal sFile As String, Optional ByVal bCaseSensitive As Boolean) As Long
Dim I As Long
For I = 0 To GetFileCount
If bCaseSensitive Then
If Files(I) = sFile Then
FileIndex = I
Exit Function
End If
Else
If LCase(Files(I)) = LCase(sFile) Then
FileIndex = I
Exit Function
End If
End If
Next I
FileIndex = -1
End Function