[VB6] Unicode File Open/Save Dialog

[LaVolpe]

No longer being updated/supported. Have moved to another version that can be found here

Edited: 6 Jan 2012. Added a unicode capable Browse for Folder dialog class
Edited: 15 Jan 2015. Updated UnicodeBrowseFolders class. See post #25 for details. This update is not hot-swappable with the previous version
** Browse for Folder dialog moved to its own thread here.

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 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

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.