mercoledì 21 settembre 2011

Create a VB Picture from a GDI Picture Handle

This tip shows you how create a VB Picture object from an GDI bitmap handle (hBitmap). This is useful if you are trying to provide VB users with a picture they can use from a GDI class.
Start a new project and add a module. Then add the following code:
Private Type PictDesc
    cbSizeofStruct As Long
    picType As Long
    hImage As Long
    xExt As Long
    yExt As Long
End Type

Private Type Guid
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type

Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" ( _
      lpPictDesc As PictDesc, _
      riid As Guid, _
      ByVal fPictureOwnsHandle As Long, _
      ipic As IPicture _
    ) As Long

Public Function BitmapToPicture(ByVal hBmp As Long) As IPicture

   If (hBmp = 0) Then Exit Function

   Dim NewPic As Picture, tPicConv As PictDesc, IGuid As Guid

   ' Fill PictDesc structure with necessary parts:
   With tPicConv
      .cbSizeofStruct = Len(tPicConv)
      .picType = vbPicTypeBitmap
      .hImage = hBmp
   End With

   ' Fill in IDispatch Interface ID
   With IGuid
      .Data1 = &H20400
      .Data4(0) = &HC0
      .Data4(7) = &H46
   End With

   ' Create a picture object:
   OleCreatePictureIndirect tPicConv, IGuid, True, NewPic
   
   ' Return it:
   Set BitmapToPicture = NewPic

End Function

To try out a the function, add a Command Button and a Picture Box to your project's form. Copy a bitmap to the project's directory, and rename it TEST.BMP.
Then add this code to the form:
Option Explicit

Private Declare Function LoadImage Lib "user32" Alias "LoadImageA" _
    (ByVal hInst As Long, ByVal lpsz As String, _
    ByVal iType As Long, _
    ByVal cx As Long, ByVal cy As Long, _
    ByVal fOptions As Long) As Long

' iType options:
Private Const IMAGE_BITMAP = 0
Private Const IMAGE_ICON = 1
Private Const IMAGE_CURSOR = 2
' fOptions flags:
Private Const LR_LOADMAP3DCOLORS = &H1000
Private Const LR_LOADFROMFILE = &H10
Private Const LR_LOADTRANSPARENT = &H20


Private Sub Command1_Click()
Dim hIcon As Long
    ' Load bitmap called Test.bmp from the directory:

    hIcon = LoadImage(App.hInstance, _
        App.Path & "\TEST.BMP", IMAGE_BITMAP, _
        0, 0, _
        LR_LOADFROMFILE Or LR_LOADMAP3DCOLORS)
    ' Set the picture to this bitmap:
    Set Picture1.Picture = BitmapToPicture(hIcon)
End Sub

Nessun commento:

Posta un commento