Wednesday 25 September 2013

How to load a picture from resource file (.res) in Visual Basic

option explicit
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 Function SetImageFromResource(Optional ByRef PB As Object = Nothing, _
                                Optional ByVal RID As String = "") As IPictureDisp
    Dim bImage() As Byte
    bImage() = LoadResData(RID, "CUSTOM")
    Set SetImageFromResource = ArrayToPicture(bImage(), 0, UBound(bImage) + 1)
    If Not PB Is Nothing Then
        If PB.Picture <> SetImageFromResource Then
            PB.Picture = SetImageFromResource
        End If
    End If
    Erase bImage
End Function

Private Function ArrayToPicture(inArray() As Byte, Offset As Long, size As Long) As IPicture
    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

No comments: