LaVolpe
Sep 28th, 2009, 12:19 PM
Edited: 6 Jan 2012. Added a unicode capable Browse for Folder dialog class
I have seen recent posts asking how to support selection of unicode filenames with the common dialog. The common dialog control offered by VB does not support unicode, but the APIs do. This class is also ANSI compatible.
The attached class wraps the Open and Save dialog and includes all of the properties offered by VB's Open/Save common dialog, along with a couple more. The additional methods/properties are:
- Clear: resets all properties to default values
- CustomFilterSize: returns/sets size of buffer for user-defined filters
- CustomHookProc: returns/sets the hook procedure for the dialog
- CustomHookData: returns/sets coder-defined value associated with the hook
- FileExtension: returns the extension of a selected file
- FilePath: returns just the path of a selected file
- FlagsEx: returns/sets additional flags for Win2K+
- MaxFileTitleSize: returns/sets buffer size for the FileTitle property
- MinimumBufferSizeRequired: returns required buffer size if multiselecting files and dialog errors with "buffer to small"
I have not included other dialogs (i.e., color, printer, font, etc). Here is another class (http://www.vbforums.com/showthread.php?t=77191) that you can use to combine codes as needed. That class has all the dialogs but does not support unicode as written. If I knew it was there before I wrote this one, I would have simply modified it instead with the author's permission.
Of course getting a unicode path/file name doesn't do you much good unless you can use it. So I assume anyone that downloads and uses this class can process the file using W-version (unicode) APIs. Trying to use LoadPicture, for example, on a unicode path/file name will generate an error on non-unicode OEM machines, but using the API LoadImageW, passing the StrPtr of the filename, will not.
Using APIs means you have to do most of the work yourself, here is a unicode-capable API-version example of loading a bitmap, gif, jpg, icon, cursor, wmf, emf to a picturebox. Somewhat simple example follows, not 100% fool-proof
' Add a picturebox and command button to a form; then:
Option Explicit
Private Type PictDesc
Size As Long
Type As Long
hHandle As Long
hPal As Long
End Type
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
Private Declare Function CreateStreamOnHGlobal Lib "ole32" (ByVal hGlobal As Long, ByVal fDeleteOnRelease As Long, ppstm As Any) As Long
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal uFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function OleLoadPicture Lib "olepro32" (pStream As Any, ByVal lSize As Long, ByVal fRunmode As Long, riid As Any, ppvObj As Any) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (lpPictDesc As PictDesc, riid As Any, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
Private Declare Function LoadImageW Lib "user32.dll" (ByVal hInst As Long, ByVal lpsz As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
Private Const IMAGE_BITMAP As Long = 0
Private Const LR_LOADFROMFILE As Long = &H10
Private Declare Function CreateFileW Lib "kernel32" (ByVal lpFileName As Long, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, ByVal lpSecurityAttributes As Long, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function GetFileSize Lib "kernel32.dll" (ByVal hFile As Long, ByRef lpFileSizeHigh As Long) As Long
Private Declare Function ReadFile Lib "kernel32.dll" (ByVal hFile As Long, ByRef lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, ByRef lpNumberOfBytesRead As Long, ByRef lpOverlapped As Any) As Long
Private Const INVALID_HANDLE_VALUE = -1&
Private Sub Command1_Click()
Dim hImage As Long, tmpPic As StdPicture
Dim hHandle As Long, imageData() As Byte, bytesRead As Long
Dim cBrowser As cOpenSaveDialog
Set cBrowser = New cOpenSaveDialog
With cBrowser
.CancelError = True
.Filter = "Bitmaps|*.bmp|JPEGs|*.jpg;*jpeg|GIFs|*.gif|Meta Files|*.wmf;*.emf|Icons/Cursors|*.ico;*.cur"
.Flags = OFN_FILEMUSTEXIST
.DialogTitle = "Select Image"
End With
On Error GoTo EH
cBrowser.ShowOpen Me.hWnd
On Error GoTo 0
' Note: You don't need to load bitmaps separately as done in this example.
' The LoadImageW call is shown only to let you see that we can pass a unicode filename
' to an API. The API declaration must be tweaked to look for a Long vs String
If cBrowser.FilterIndex = 1 Then ' loaded a .bmp file?
hImage = LoadImageW(0&, StrPtr(cBrowser.FileName), IMAGE_BITMAP, 0&, 0&, LR_LOADFROMFILE)
If hImage Then Set tmpPic = HandleToStdPicture(hImage, vbPicTypeBitmap)
Else ' loaded a gif, jpg or possibly something else?
hHandle = GetFileHandle(cBrowser.FileName)
If hHandle <> INVALID_HANDLE_VALUE Then
If hHandle Then
bytesRead = GetFileSize(hHandle, ByVal 0&)
If bytesRead Then
ReDim imageData(0 To bytesRead - 1)
ReadFile hHandle, imageData(0), bytesRead, bytesRead, ByVal 0&
If bytesRead > UBound(imageData) Then
Set tmpPic = ArrayToPicture(imageData(), 0, bytesRead)
End If
End If
CloseHandle hHandle
End If
End If
End If
If tmpPic Is Nothing Then
MsgBox "Error loading that file", vbOKOnly + vbExclamation
Else
Set Picture1.Picture = tmpPic
End If
EH:
If Err Then
If Err.Number <> CommonDialogErrorsEnum.CDERR_CANCELED Then
MsgBox Err.Description, vbOKOnly, "Error Encountered"
End If
Err.Clear
End If
End Sub
Private Function HandleToStdPicture(ByVal hImage As Long, ByVal imgType As Long) As IPicture
' function creates a stdPicture object from an image handle (bitmap or icon)
Dim lpPictDesc As PictDesc, aGUID(0 To 3) As Long
With lpPictDesc
.Size = Len(lpPictDesc)
.Type = imgType
.hHandle = hImage
.hPal = 0
End With
' IPicture GUID {7BF80980-BF32-101A-8BBB-00AA00300CAB}
aGUID(0) = &H7BF80980
aGUID(1) = &H101ABF32
aGUID(2) = &HAA00BB8B
aGUID(3) = &HAB0C3000
' create stdPicture
Call OleCreatePictureIndirect(lpPictDesc, aGUID(0), True, HandleToStdPicture)
End Function
Private Function ArrayToPicture(inArray() As Byte, Offset As Long, Size As Long) As IPicture
' function creates a stdPicture from the passed array
' Note: The array was already validated as not empty when calling class' LoadStream was called
Dim o_hMem As Long
Dim o_lpMem As Long
Dim aGUID(0 To 3) As Long
Dim IIStream As IUnknown
aGUID(0) = &H7BF80980 ' GUID for stdPicture
aGUID(1) = &H101ABF32
aGUID(2) = &HAA00BB8B
aGUID(3) = &HAB0C3000
o_hMem = GlobalAlloc(&H2&, Size)
If Not o_hMem = 0& Then
o_lpMem = GlobalLock(o_hMem)
If Not o_lpMem = 0& Then
CopyMemory ByVal o_lpMem, inArray(Offset), Size
Call GlobalUnlock(o_hMem)
If CreateStreamOnHGlobal(o_hMem, 1&, IIStream) = 0& Then
Call OleLoadPicture(ByVal ObjPtr(IIStream), 0&, 0&, aGUID(0), ArrayToPicture)
End If
End If
End If
End Function
Private Function GetFileHandle(ByVal FileName As String) As Long
' Function uses APIs to read/create files with unicode support
Const GENERIC_READ As Long = &H80000000
Const OPEN_EXISTING = &H3
Const FILE_SHARE_READ = &H1
Const FILE_ATTRIBUTE_ARCHIVE As Long = &H20
Const FILE_ATTRIBUTE_HIDDEN As Long = &H2
Const FILE_ATTRIBUTE_READONLY As Long = &H1
Const FILE_ATTRIBUTE_SYSTEM As Long = &H4
Const FILE_ATTRIBUTE_NORMAL = &H80&
Dim Flags As Long, Access As Long
Dim Disposition As Long, Share As Long
Access = GENERIC_READ
Share = FILE_SHARE_READ
Disposition = OPEN_EXISTING
Flags = FILE_ATTRIBUTE_ARCHIVE Or FILE_ATTRIBUTE_HIDDEN Or FILE_ATTRIBUTE_NORMAL _
Or FILE_ATTRIBUTE_READONLY Or FILE_ATTRIBUTE_SYSTEM
GetFileHandle = CreateFileW(StrPtr(FileName), Access, Share, ByVal 0&, Disposition, Flags, 0&)
End Function
Private Sub Form_Load()
Picture1.AutoSize = True
End Sub
Example of using the folder browser and setting an initial directory.
' in a module add these lines of code
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Any) As Long
Private Const WM_USER = &H400
Private Const BFFM_SETSELECTION = (WM_USER + 102)
Private Const BFFM_INITIALIZED = 1
Public Function BrowseCallbackProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal lp As Long, ByVal lParam As Long) As Long
Select Case uMsg
Case BFFM_INITIALIZED
' http://msdn.microsoft.com/en-us/library/aa452875.aspx
' the 3rd parameter of SendMessage is either zero or non-zero
' zero :: lParam is a PIDL (as used below)
' non-zero :: lParam is yourDesiredInitialDirectoryPath string
Call SendMessage(hWnd, BFFM_SETSELECTION, 0&, ByVal lParam)
' other Case BFFM_xxxx messages as desired
End Select
BrowseCallbackProc = 0&
End Function
Public Function GetAddressofFunction(addr As Long) As Long
GetAddressofFunction = addr
End Function
' how to call the class & set the initial directory from within your form
Private Sub Command1_Click()
Dim cBrowser As cBrowseFolders, tPIDL As Long
Set cBrowser = New cBrowseFolders
On Error GoTo ExitRoutine
tPIDL = cBrowser.CreatePIDLfromFolder("C:\Program Files\Realtek\Audio")
cBrowser.CustomHookProc = GetAddressofFunction(AddressOf BrowseCallbackProc)
cBrowser.CustomHookData = tPIDL
cBrowser.ShowBrowseForFolder Me.hWnd, True
' ^^ if you need the return PIDL; don't set final parameter to True, but do destroy it at some point
' if user selected non-virtual folder then cBrowser.SelectedItem contains path
ExitRoutine:
cBrowser.DestroyPIDL tPIDL ' destroy PIDL you created
End Sub
Since this is a class and errors are raised if the CancelError property is set to true, VB may stop in the class when the error is raised. If VB does stop, it is due to your VB settings. If you have error trapping option to "Break in Class Modules", change it to "Break on Unhandled Errors". That error is required in order to mimic common dialog's CancelError property. The VB stopping applies only to IDE not if project is compiled.
I have seen recent posts asking how to support selection of unicode filenames with the common dialog. The common dialog control offered by VB does not support unicode, but the APIs do. This class is also ANSI compatible.
The attached class wraps the Open and Save dialog and includes all of the properties offered by VB's Open/Save common dialog, along with a couple more. The additional methods/properties are:
- Clear: resets all properties to default values
- CustomFilterSize: returns/sets size of buffer for user-defined filters
- CustomHookProc: returns/sets the hook procedure for the dialog
- CustomHookData: returns/sets coder-defined value associated with the hook
- FileExtension: returns the extension of a selected file
- FilePath: returns just the path of a selected file
- FlagsEx: returns/sets additional flags for Win2K+
- MaxFileTitleSize: returns/sets buffer size for the FileTitle property
- MinimumBufferSizeRequired: returns required buffer size if multiselecting files and dialog errors with "buffer to small"
I have not included other dialogs (i.e., color, printer, font, etc). Here is another class (http://www.vbforums.com/showthread.php?t=77191) that you can use to combine codes as needed. That class has all the dialogs but does not support unicode as written. If I knew it was there before I wrote this one, I would have simply modified it instead with the author's permission.
Of course getting a unicode path/file name doesn't do you much good unless you can use it. So I assume anyone that downloads and uses this class can process the file using W-version (unicode) APIs. Trying to use LoadPicture, for example, on a unicode path/file name will generate an error on non-unicode OEM machines, but using the API LoadImageW, passing the StrPtr of the filename, will not.
Using APIs means you have to do most of the work yourself, here is a unicode-capable API-version example of loading a bitmap, gif, jpg, icon, cursor, wmf, emf to a picturebox. Somewhat simple example follows, not 100% fool-proof
' Add a picturebox and command button to a form; then:
Option Explicit
Private Type PictDesc
Size As Long
Type As Long
hHandle As Long
hPal As Long
End Type
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
Private Declare Function CreateStreamOnHGlobal Lib "ole32" (ByVal hGlobal As Long, ByVal fDeleteOnRelease As Long, ppstm As Any) As Long
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal uFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function OleLoadPicture Lib "olepro32" (pStream As Any, ByVal lSize As Long, ByVal fRunmode As Long, riid As Any, ppvObj As Any) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (lpPictDesc As PictDesc, riid As Any, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
Private Declare Function LoadImageW Lib "user32.dll" (ByVal hInst As Long, ByVal lpsz As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
Private Const IMAGE_BITMAP As Long = 0
Private Const LR_LOADFROMFILE As Long = &H10
Private Declare Function CreateFileW Lib "kernel32" (ByVal lpFileName As Long, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, ByVal lpSecurityAttributes As Long, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function GetFileSize Lib "kernel32.dll" (ByVal hFile As Long, ByRef lpFileSizeHigh As Long) As Long
Private Declare Function ReadFile Lib "kernel32.dll" (ByVal hFile As Long, ByRef lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, ByRef lpNumberOfBytesRead As Long, ByRef lpOverlapped As Any) As Long
Private Const INVALID_HANDLE_VALUE = -1&
Private Sub Command1_Click()
Dim hImage As Long, tmpPic As StdPicture
Dim hHandle As Long, imageData() As Byte, bytesRead As Long
Dim cBrowser As cOpenSaveDialog
Set cBrowser = New cOpenSaveDialog
With cBrowser
.CancelError = True
.Filter = "Bitmaps|*.bmp|JPEGs|*.jpg;*jpeg|GIFs|*.gif|Meta Files|*.wmf;*.emf|Icons/Cursors|*.ico;*.cur"
.Flags = OFN_FILEMUSTEXIST
.DialogTitle = "Select Image"
End With
On Error GoTo EH
cBrowser.ShowOpen Me.hWnd
On Error GoTo 0
' Note: You don't need to load bitmaps separately as done in this example.
' The LoadImageW call is shown only to let you see that we can pass a unicode filename
' to an API. The API declaration must be tweaked to look for a Long vs String
If cBrowser.FilterIndex = 1 Then ' loaded a .bmp file?
hImage = LoadImageW(0&, StrPtr(cBrowser.FileName), IMAGE_BITMAP, 0&, 0&, LR_LOADFROMFILE)
If hImage Then Set tmpPic = HandleToStdPicture(hImage, vbPicTypeBitmap)
Else ' loaded a gif, jpg or possibly something else?
hHandle = GetFileHandle(cBrowser.FileName)
If hHandle <> INVALID_HANDLE_VALUE Then
If hHandle Then
bytesRead = GetFileSize(hHandle, ByVal 0&)
If bytesRead Then
ReDim imageData(0 To bytesRead - 1)
ReadFile hHandle, imageData(0), bytesRead, bytesRead, ByVal 0&
If bytesRead > UBound(imageData) Then
Set tmpPic = ArrayToPicture(imageData(), 0, bytesRead)
End If
End If
CloseHandle hHandle
End If
End If
End If
If tmpPic Is Nothing Then
MsgBox "Error loading that file", vbOKOnly + vbExclamation
Else
Set Picture1.Picture = tmpPic
End If
EH:
If Err Then
If Err.Number <> CommonDialogErrorsEnum.CDERR_CANCELED Then
MsgBox Err.Description, vbOKOnly, "Error Encountered"
End If
Err.Clear
End If
End Sub
Private Function HandleToStdPicture(ByVal hImage As Long, ByVal imgType As Long) As IPicture
' function creates a stdPicture object from an image handle (bitmap or icon)
Dim lpPictDesc As PictDesc, aGUID(0 To 3) As Long
With lpPictDesc
.Size = Len(lpPictDesc)
.Type = imgType
.hHandle = hImage
.hPal = 0
End With
' IPicture GUID {7BF80980-BF32-101A-8BBB-00AA00300CAB}
aGUID(0) = &H7BF80980
aGUID(1) = &H101ABF32
aGUID(2) = &HAA00BB8B
aGUID(3) = &HAB0C3000
' create stdPicture
Call OleCreatePictureIndirect(lpPictDesc, aGUID(0), True, HandleToStdPicture)
End Function
Private Function ArrayToPicture(inArray() As Byte, Offset As Long, Size As Long) As IPicture
' function creates a stdPicture from the passed array
' Note: The array was already validated as not empty when calling class' LoadStream was called
Dim o_hMem As Long
Dim o_lpMem As Long
Dim aGUID(0 To 3) As Long
Dim IIStream As IUnknown
aGUID(0) = &H7BF80980 ' GUID for stdPicture
aGUID(1) = &H101ABF32
aGUID(2) = &HAA00BB8B
aGUID(3) = &HAB0C3000
o_hMem = GlobalAlloc(&H2&, Size)
If Not o_hMem = 0& Then
o_lpMem = GlobalLock(o_hMem)
If Not o_lpMem = 0& Then
CopyMemory ByVal o_lpMem, inArray(Offset), Size
Call GlobalUnlock(o_hMem)
If CreateStreamOnHGlobal(o_hMem, 1&, IIStream) = 0& Then
Call OleLoadPicture(ByVal ObjPtr(IIStream), 0&, 0&, aGUID(0), ArrayToPicture)
End If
End If
End If
End Function
Private Function GetFileHandle(ByVal FileName As String) As Long
' Function uses APIs to read/create files with unicode support
Const GENERIC_READ As Long = &H80000000
Const OPEN_EXISTING = &H3
Const FILE_SHARE_READ = &H1
Const FILE_ATTRIBUTE_ARCHIVE As Long = &H20
Const FILE_ATTRIBUTE_HIDDEN As Long = &H2
Const FILE_ATTRIBUTE_READONLY As Long = &H1
Const FILE_ATTRIBUTE_SYSTEM As Long = &H4
Const FILE_ATTRIBUTE_NORMAL = &H80&
Dim Flags As Long, Access As Long
Dim Disposition As Long, Share As Long
Access = GENERIC_READ
Share = FILE_SHARE_READ
Disposition = OPEN_EXISTING
Flags = FILE_ATTRIBUTE_ARCHIVE Or FILE_ATTRIBUTE_HIDDEN Or FILE_ATTRIBUTE_NORMAL _
Or FILE_ATTRIBUTE_READONLY Or FILE_ATTRIBUTE_SYSTEM
GetFileHandle = CreateFileW(StrPtr(FileName), Access, Share, ByVal 0&, Disposition, Flags, 0&)
End Function
Private Sub Form_Load()
Picture1.AutoSize = True
End Sub
Example of using the folder browser and setting an initial directory.
' in a module add these lines of code
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Any) As Long
Private Const WM_USER = &H400
Private Const BFFM_SETSELECTION = (WM_USER + 102)
Private Const BFFM_INITIALIZED = 1
Public Function BrowseCallbackProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal lp As Long, ByVal lParam As Long) As Long
Select Case uMsg
Case BFFM_INITIALIZED
' http://msdn.microsoft.com/en-us/library/aa452875.aspx
' the 3rd parameter of SendMessage is either zero or non-zero
' zero :: lParam is a PIDL (as used below)
' non-zero :: lParam is yourDesiredInitialDirectoryPath string
Call SendMessage(hWnd, BFFM_SETSELECTION, 0&, ByVal lParam)
' other Case BFFM_xxxx messages as desired
End Select
BrowseCallbackProc = 0&
End Function
Public Function GetAddressofFunction(addr As Long) As Long
GetAddressofFunction = addr
End Function
' how to call the class & set the initial directory from within your form
Private Sub Command1_Click()
Dim cBrowser As cBrowseFolders, tPIDL As Long
Set cBrowser = New cBrowseFolders
On Error GoTo ExitRoutine
tPIDL = cBrowser.CreatePIDLfromFolder("C:\Program Files\Realtek\Audio")
cBrowser.CustomHookProc = GetAddressofFunction(AddressOf BrowseCallbackProc)
cBrowser.CustomHookData = tPIDL
cBrowser.ShowBrowseForFolder Me.hWnd, True
' ^^ if you need the return PIDL; don't set final parameter to True, but do destroy it at some point
' if user selected non-virtual folder then cBrowser.SelectedItem contains path
ExitRoutine:
cBrowser.DestroyPIDL tPIDL ' destroy PIDL you created
End Sub
Since this is a class and errors are raised if the CancelError property is set to true, VB may stop in the class when the error is raised. If VB does stop, it is due to your VB settings. If you have error trapping option to "Break in Class Modules", change it to "Break on Unhandled Errors". That error is required in order to mimic common dialog's CancelError property. The VB stopping applies only to IDE not if project is compiled.