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
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:
Post a Comment