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