Пример OLE + DrawTransparent
Данный пример загружает прозрачный GIF рисунок с помощью OleLoadPicture. Далее битмап рисуется с прозрачностью на окне с новым фоном и сохраняется как BMP изображение с помощью OleSavePictureFile. Для примера я использовал изображение ниже.
Платформа: Windows
Автор: Станислав Будинов
#INCLUDE Once "windows.bi" #INCLUDE Once "win/olectl.bi" Type OLE file As HANDLE Size As Integer hGlobal As HGLOBAL pdata As HGLOBAL getbytes As Integer FRead As Boolean tempDC As HDC tempBitmap As HBITMAP OldBitmap As HBITMAP compDC As HDC Width As Integer height As Integer widthbitmap As Integer heightbitmap As Integer pIPicture As IPicture Ptr IPictures As IPictureVtbl Ptr pIStream As Any Ptr IStream As IStreamVtbl Ptr End Type Type OLE2 As PICTDESC pDesc As IPicture Ptr pPicture As BOOL bResult = TRUE As Integer blen As Wstring Ptr wbuf End Type Type DTP As BITMAP bm As COLORREF cColor As HBITMAP bmAndBack, bmAndObject, bmAndMem, bmSave As HBITMAP bmBackOld, bmObjectOld, bmMemOld, bmSaveOld As HDC hdcMem, hdcBack, hdcObject, hdcTemp, hdcSave As Point ptSize End Type Type OLEALL ole As OLE ole2 As OLE2 dtp As DTP Declare Sub DrawTransparentBitmap(hdc As HDC ,hBitmap As HBITMAP ,xStart As Short ,yStart As Short ,cTransparentColor As COLORREF ) Declare Function OleLoadBitmap(lpszFile As String , w As Integer = 0, h As Integer = 0) As HBITMAP Declare Function OleSaveBitmap(hBitmap As HBITMAP,Path As String) As bool End Type Sub OLEALL.DrawTransparentBitmap(hdc As HDC ,hBitmap As HBITMAP ,xStart As Short ,yStart As Short ,cTransparentColor As COLORREF ) With dtp .hdcTemp = CreateCompatibleDC(hdc) SelectObject(.hdcTemp, hBitmap) GetObject(hBitmap, Sizeof(BITMAP),@.bm) .ptSize.x = .bm.bmWidth .ptSize.y = .bm.bmHeight DPtoLP(.hdcTemp, @.ptSize, 1) .hdcBack = CreateCompatibleDC(hdc) .hdcObject = CreateCompatibleDC(hdc) .hdcMem = CreateCompatibleDC(hdc) .hdcSave = CreateCompatibleDC(hdc) .bmAndBack = CreateBitmap(.ptSize.x, .ptSize.y, 1, 1, NULL) .bmAndObject = CreateBitmap(.ptSize.x, .ptSize.y, 1, 1, NULL) .bmAndMem = CreateCompatibleBitmap(hdc, .ptSize.x, .ptSize.y) .bmSave = CreateCompatibleBitmap(hdc, .ptSize.x, .ptSize.y) .bmBackOld = SelectObject(.hdcBack, .bmAndBack) .bmObjectOld = SelectObject(.hdcObject, .bmAndObject) .bmMemOld = SelectObject(.hdcMem, .bmAndMem) .bmSaveOld = SelectObject(.hdcSave, .bmSave) SetMapMode(.hdcTemp, GetMapMode(hdc)) BitBlt(.hdcSave, 0, 0, .ptSize.x, .ptSize.y, .hdcTemp, 0, 0, SRCCOPY) .cColor = SetBkColor(.hdcTemp, cTransparentColor) BitBlt(.hdcObject, 0, 0, .ptSize.x, .ptSize.y, .hdcTemp, 0, 0,SRCCOPY) SetBkColor(.hdcTemp, .cColor) BitBlt(.hdcBack, 0, 0, .ptSize.x, .ptSize.y, .hdcObject, 0, 0,NOTSRCCOPY) BitBlt(.hdcMem, 0, 0, .ptSize.x, .ptSize.y, hdc, xStart, yStart,SRCCOPY) BitBlt(.hdcMem, 0, 0, .ptSize.x, .ptSize.y, .hdcObject, 0, 0, SRCAND) BitBlt(.hdcTemp, 0, 0, .ptSize.x, .ptSize.y, .hdcBack, 0, 0, SRCAND) BitBlt(.hdcMem, 0, 0, .ptSize.x, .ptSize.y, .hdcTemp, 0, 0, SRCPAINT) BitBlt(hdc, xStart, yStart, .ptSize.x, .ptSize.y, .hdcMem, 0, 0,SRCCOPY) BitBlt(.hdcTemp, 0, 0, .ptSize.x, .ptSize.y, .hdcSave, 0, 0, SRCCOPY) DeleteObject(SelectObject(.hdcBack, .bmBackOld)) DeleteObject(SelectObject(.hdcObject, .bmObjectOld)) DeleteObject(SelectObject(.hdcMem, .bmMemOld)) DeleteObject(SelectObject(.hdcSave, .bmSaveOld)) DeleteDC(.hdcMem) DeleteDC(.hdcBack) DeleteDC(.hdcObject) DeleteDC(.hdcSave) DeleteDC(.hdcTemp) End With End Sub Function OLEALL.OleLoadBitmap(lpszFile As String , w As Integer = 0, h As Integer = 0) As HBITMAP With ole .file=CreateFile(lpszFile,GENERIC_READ,FILE_SHARE_READ,NULL,OPEN_EXISTING,0,NULL) If .file <> -1 Then .Size=GetFileSize(.file,NULL) .hGlobal=GlobalAlloc(GMEM_MOVEABLE,.Size) .pdata=GlobalLock(.hGlobal) .Fread=ReadFile(.file,.pdata,.Size,@.getbytes,NULL) GlobalUnlock(.hGlobal) CloseHandle(.file) CreateStreamOnHGlobal(.hGlobal,TRUE,@.pIStream) If .pIStream Then .IStream=Cast(IStreamVtbl Ptr,Peek(DWORD,.pIStream)) OleLoadPicture(.pIStream,.Size,FALSE,@IID_IPicture,@.pIPicture) If .pIPicture Then .IPictures=Cast(IPictureVtbl Ptr,Peek(DWORD,.pIPicture)) Endif .IStream->Release(.pIStream) Endif GlobalFree(.hGlobal) Endif .compDC=GetDC(NULL) .tempDC=CreateCompatibleDC(.compDC) .IPictures->get_Width(.pIPicture,@.width) .IPictures->get_Height(.pIPicture,@.height) If w=0 Or h=0 Then w = (.width * GetDeviceCaps(.compDC,LOGPIXELSY)) / 2540 h = (.height * GetDeviceCaps(.compDC,LOGPIXELSX)) / 2540 .widthbitmap=w : .heightbitmap=h Endif .tempBitmap=CreateCompatibleBitmap(.compDC,w,h) .OldBitmap=SelectObject(.tempDC,.tempBitmap) .IPictures->Render(.pIPicture,.tempDC,0,0,w,h,0,.height,.width,-.height,NULL) SelectObject(.tempDC,.OldBitmap) DeleteDC(.tempDC) ReleaseDC(NULL,.compDC) Return .tempBitmap End With End Function Function OLEALL.OleSaveBitmap(hBitmap As HBITMAP,Path As String) As bool With ole2 .pDesc.cbSizeofstruct = Sizeof(PICTDESC) .pDesc.bmp.hbitmap = hBitmap .pDesc.picType = PICTYPE_BITMAP OleCreatePictureIndirect(@.pDesc,@IID_IPicture,FALSE,@.pPicture) If .pPicture=NULL Then Return FALSE Else .blen = (Len(Path)*2)+2 .wbuf = Allocate(.blen) MultiByteToWideChar(CP_ACP, 0,Path, -1, .wbuf, .blen) OleSavePictureFile(Cast(LPDISPATCH,.pPicture),.wbuf) IPicture_Release(.pPicture) Deallocate(.wbuf) Endif End With Return TRUE End Function ' Пример использования Dim As HBITMAP bmp,bmp1,nullbitmap Dim msg As MSG Dim As HWND hwnd Dim As HDC hdc,hdc2 Dim As HBRUSH brush,nullbrush,nullbrush2 Dim As OLEALL obj bmp = obj.OleLoadBitmap("ex.gif") bmp1 = CreateBitmap(obj.ole.widthbitmap ,obj.ole.heightbitmap,1,32,0) hwnd=CreateWindowEx(0,"#32770","OLE",WS_VISIBLE Or WS_OVERLAPPEDWINDOW,100,100,190,300,0,0,0,0) 'рисуем на окне hdc=GetDC(hwnd) brush=CreateSolidBrush(&h00DDFF) nullbrush=selectobject(hdc,brush) ExtFloodFill (hdc, 10,10,&hf0f0f0, FLOODFILLSURFACE) obj.DrawTransparentBitmap(hdc,bmp,10,10,&h0) 'рисуем на изображении hdc2=CreateCompatibleDC(hdc) nullbitmap=selectobject(hdc2,bmp1) nullbrush2=selectobject(hdc2,brush) ExtFloodFill (hdc2, 10,10,0, FLOODFILLSURFACE) obj.DrawTransparentBitmap(hdc2,bmp,0,0,&h0) obj.OleSaveBitmap(bmp1,"ex.bmp") SelectObject(hdc2, nullbrush2) DeleteObject(SelectObject(hdc, nullbrush)) DeleteObject(SelectObject(hdc, nullbitmap)) DeleteObject(bmp) DeleteObject(bmp1) DeleteDC(hdc2) DeleteDC(hdc) While GetMessage(@msg,0,0,0) DispatchMessage(@msg) If msg.message=WM_COMMAND Then Exit While Wend
