Option Explicit
Private Const DIB_RGB_COLORS As Long = 0
'bitmap information
Private Type BITMAP
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
bmBits As Long
End Type
Private Type BMP_GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
Private Type BMP_PICTURE
Size As Long
Type As Long
hBmp As Long
hPal As Long
Reserved As Long
End Type
'images in memory
Private Declare Function CreateBitmap Lib "gdi32" (ByVal nWidth As Long, ByVal nHeight As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, lpBits As Any) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function GetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
Private Declare Function SetDIBits_8 Lib "gdi32" Alias "SetDIBits" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpbi As BITMAPINFO_8, ByVal wUsage As Long) As Long
Private Declare Function CreatePalette Lib "gdi32" (lpLogPalette As LOGPALETTE) As Long
Private Declare Function RealizePalette Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function SelectPalette Lib "gdi32" (ByVal hDC As Long, ByVal hPalette As Long, ByVal bForceBackground As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As BMP_PICTURE, RefIID As BMP_GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private InUseScreen As Boolean, InUseImage As Boolean
Private ScreenDC As Long, PicDC As Long, DestDC As Long
Private PicBmp As Long, PicPrevBmp As Long, PicPal As Long, PicPrevPal As Long
Private Width As Long, Height As Long
'initial step: get screen DC as default DC
Private Sub Class_Initialize()
Init GetDC(0)
End Sub
'last step: free memory
Private Sub Class_Terminate()
If InUseImage Then ClearImage
'free Dc
Call ReleaseDC(0, ScreenDC)
InUseScreen = False
End Sub
Public Sub ClearImage()
Dim PrevBmp As Long
'free image
If InUseImage Then
PrevBmp = SelectObject(PicDC, PicPrevBmp)
Call DeleteObject(PicBmp)
Call DeleteDC(PicDC)
InUseImage = False
End If
End Sub
'alternative step: change DC
Public Sub Init(hDC As Long)
'do a proper clearing before filling up with new information (if required)
If InUseScreen Then Class_Terminate
'set default DC
ScreenDC = hDC
PicDC = CreateCompatibleDC(ScreenDC)
'mark we have filled DC
InUseScreen = True
End Sub
'step 3: view the image
Property Get Picture() As IPictureDisp
Dim Pic As BMP_PICTURE, IPic As IPicture, IID_IDispatch As BMP_GUID
'fill GUID info (whatever it is...)
With IID_IDispatch
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With
'fill picture info
With Pic
.Size = Len(Pic) ' Length of structure
.Type = vbPicTypeBitmap ' Type of Picture (bitmap)
.hBmp = PicBmp ' Handle to bitmap
.hPal = PicPal ' Handle to palette (may be null)
End With
Call OleCreatePictureIndirect(Pic, IID_IDispatch, 1, IPic)
'view picture in destination
Set Picture = IPic
End Property
'step 1: image must be set
Public Sub SetImage(ByRef Info As BITMAPINFO_8, ByRef DataArray() As Byte)
'do a proper clearing before new image
If InUseImage Then ClearImage
'create image
PicBmp = CreateCompatibleBitmap(ScreenDC, Width, Height)
PicPrevBmp = SelectObject(PicDC, PicBmp)
'set image bits
Call SetDIBits_8(PicDC, PicBmp, 0, Width, DataArray(0), Info, DIB_RGB_COLORS)
'mark image to be in use
InUseImage = True
End Sub
'step 2: palette must be set
Public Sub SetPalette(ByRef DataArray() As Byte)
Dim BmpPal As BITMAPPALETTE
'init palette
BmpPal.palVersion = &H300
BmpPal.palNumEntries = 256
RtlMoveMemory VarPtr(BmpPal.palPalEntry(0)), VarPtr(DataArray(0)), 1024
'create palette and set it in use
PicPal = CreatePalette(BmpPal)
PicPrevPal = SelectPalette(PicDC, PicPal, 0)
Call RealizePalette(PicDC)
End Sub