You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
234 lines
10 KiB
234 lines
10 KiB
Attribute VB_Name = "PaintSup"
|
|
Option Explicit
|
|
|
|
'-----------------------------------------------------------------
|
|
Public Function ShrinkBmp(dispHdc As Long, hBmp As Long, RatioX As Single, RatioY As Single) As Long
|
|
'-----------------------------------------------------------------
|
|
Dim hBmpOut As Long ' output bitmap handle
|
|
Dim bm1 As BITMAP, bm2 As BITMAP ' temporary bitmap structs
|
|
Dim hdcMem1 As Long, hdcMem2 As Long ' temporary memory bitmap handles...
|
|
'-----------------------------------------------------------------
|
|
hdcMem1 = CreateCompatibleDC(dispHdc) ' create mem DC compatible to the display DC
|
|
hdcMem2 = CreateCompatibleDC(dispHdc) ' create mem DC compatible to the display DC
|
|
|
|
GetObject hBmp, LenB(bm1), bm1 ' select bitmap object
|
|
|
|
LSet bm2 = bm1 ' copy bitmap object
|
|
|
|
bm2.bmWidth = CLng(bm2.bmWidth * RatioX) ' scale output bitmap width
|
|
bm2.bmHeight = CLng(bm2.bmHeight * RatioY) ' scale output bitmap height
|
|
bm2.bmWidthBytes = ((((bm2.bmWidth * bm2.bmBitsPixel) + 15) \ 16) * 2) ' calculate bitmap width bytes
|
|
|
|
hBmpOut = CreateBitmapIndirect(bm2) ' create handle to output bitmap indirectly from new bm2
|
|
|
|
SelectObject hdcMem1, hBmp ' select original bitmap into mem dc
|
|
SelectObject hdcMem2, hBmpOut ' select new bitmap into mem dc
|
|
|
|
' stretch old bitmap into new bitmap
|
|
StretchBlt hdcMem2, 0, 0, bm2.bmWidth, bm2.bmHeight, _
|
|
hdcMem1, 0, 0, bm1.bmWidth, bm1.bmHeight, vbSrcCopy
|
|
|
|
DeleteDC hdcMem1 ' delete memory dc
|
|
DeleteDC hdcMem2 ' delete memory dc
|
|
|
|
ShrinkBmp = hBmpOut ' return handle to new bitmap
|
|
'-----------------------------------------------------------------
|
|
End Function
|
|
'-----------------------------------------------------------------
|
|
|
|
'-----------------------------------------------------------------
|
|
Public Sub InitDeskDC(OutHdc As Long, OutBmp As BITMAP, DispRec As RECT)
|
|
'-----------------------------------------------------------------
|
|
Dim DskHwnd As Long ' hWnd of desktop
|
|
Dim DskRect As RECT ' rect size of desktop
|
|
Dim DskHdc As Long ' hdc of desktop
|
|
Dim hOutBmp As Long ' handle to output bitmap
|
|
Dim rc As Long ' function return code
|
|
'-----------------------------------------------------------------
|
|
DskHwnd = GetDesktopWindow() ' Get src - HWND of Desktop
|
|
DskHdc = GetWindowDC(DskHwnd) ' Get src HDC - Handle to device context
|
|
rc = GetWindowRect(DskHwnd, DskRect) ' Get src Rectangle dimentions
|
|
|
|
With DispRec
|
|
' Create handle to compatible output bitmap
|
|
hOutBmp = CreateCompatibleBitmap(DskHdc, (.Right - .Left + 1), (.Bottom - .Top + 1))
|
|
|
|
rc = GetObject(hOutBmp, Len(OutBmp), OutBmp) ' Get handle to bitmap
|
|
OutHdc = CreateCompatibleDC(DskHdc) ' Create compatible hdc
|
|
rc = SelectObject(OutHdc, hOutBmp) ' copy bitmap structure into output dc
|
|
|
|
rc = StretchBlt(OutHdc, 0, 0, _
|
|
(.Right - .Left + 1), _
|
|
(.Bottom - .Top + 1), _
|
|
DskHdc, 0, 0, _
|
|
(DskRect.Right - DskRect.Left + 1), _
|
|
(DskRect.Bottom - DskRect.Top + 1), _
|
|
vbSrcCopy) ' Paint bitmap desk dc to output dc
|
|
End With
|
|
|
|
rc = DeleteObject(hOutBmp) ' delete handle to output bitmap
|
|
rc = ReleaseDC(DskHwnd, DskHdc) ' Clean up - Release src HDC
|
|
'-----------------------------------------------------------------
|
|
End Sub
|
|
'-----------------------------------------------------------------
|
|
|
|
'-----------------------------------------------------------------
|
|
Public Sub PaintDeskDC(InHdc As Long, InBmp As BITMAP, OutHwnd As Long)
|
|
'-----------------------------------------------------------------
|
|
Dim OutRect As RECT ' rect. size of output window
|
|
Dim OutHdc As Long ' hdc of output window
|
|
Dim rc As Long ' function return code
|
|
'-----------------------------------------------------------------
|
|
rc = GetClientRect(OutHwnd, OutRect) ' Get Dest Rectangle dimentions
|
|
OutHdc = GetWindowDC(OutHwnd) ' get Dest HDC
|
|
|
|
With OutRect
|
|
' Paint the desktop picture to the output window...
|
|
rc = StretchBlt(OutHdc, 0, 0, _
|
|
(.Right - .Left + 1), _
|
|
(.Bottom - .Top + 1), _
|
|
InHdc, 0, 0, _
|
|
InBmp.bmWidth, InBmp.bmHeight, vbSrcCopy)
|
|
End With
|
|
|
|
rc = ReleaseDC(OutHwnd, OutHdc) ' Clean up - Release src HDC
|
|
'-----------------------------------------------------------------
|
|
End Sub
|
|
'-----------------------------------------------------------------
|
|
|
|
'-----------------------------------------------------------------
|
|
Public Sub DelDeskDC(OutHdc As Long)
|
|
'-----------------------------------------------------------------
|
|
Dim rc As Long
|
|
'-----------------------------------------------------------------
|
|
|
|
rc = DeleteDC(OutHdc) ' Clean up - Release src HDC
|
|
'-----------------------------------------------------------------
|
|
End Sub
|
|
'-----------------------------------------------------------------
|
|
|
|
'-----------------------------------------------------------------
|
|
Public Sub DrawTransparentBitmap(lHDCDest As Long, _
|
|
lBmSource As Long, _
|
|
lMaskColor As Long, _
|
|
Optional lDestStartX As Long, _
|
|
Optional lDestStartY As Long, _
|
|
Optional lDestWidth As Long, _
|
|
Optional lDestHeight As Long, _
|
|
Optional lSrcStartX As Long, _
|
|
Optional lSrcStartY As Long, _
|
|
Optional BkGrndHdc As Long)
|
|
'-----------------------------------------------------------------
|
|
Dim udtBitMap As BITMAP
|
|
Dim lColorRef As Long 'COLORREF
|
|
Dim lBmAndBack As Long 'HBITMAP
|
|
Dim lBmAndObject As Long
|
|
Dim lBmAndMem As Long
|
|
Dim lBmSave As Long
|
|
Dim lBmBackOld As Long
|
|
Dim lBmObjectOld As Long
|
|
Dim lBmMemOld As Long
|
|
Dim lBmSaveOld As Long
|
|
Dim lHDCMem As Long 'HDC
|
|
Dim lHDCBack As Long
|
|
Dim lHDCObject As Long
|
|
Dim lHDCTemp As Long
|
|
Dim lHDCSave As Long
|
|
Dim udtSize As POINTAPI 'POINT
|
|
Dim x As Long, y As Long
|
|
'-----------------------------------------------------------------
|
|
lHDCTemp = CreateCompatibleDC(lHDCDest) 'Create a temporary HDC compatible to the Destination HDC
|
|
SelectObject lHDCTemp, lBmSource 'Select the bitmap
|
|
GetObject lBmSource, Len(udtBitMap), udtBitMap
|
|
|
|
With udtSize
|
|
.x = udtBitMap.bmWidth 'Get width of bitmap
|
|
.y = udtBitMap.bmHeight 'Get height of bitmap
|
|
'Use passed width and height parameters
|
|
If lDestWidth <> 0 Then .x = lDestWidth
|
|
If lDestHeight <> 0 Then .y = lDestHeight
|
|
x = .x
|
|
y = .y
|
|
End With
|
|
|
|
'Create some DCs to hold temporary data
|
|
lHDCBack = CreateCompatibleDC(lHDCDest)
|
|
lHDCObject = CreateCompatibleDC(lHDCDest)
|
|
lHDCMem = CreateCompatibleDC(lHDCDest)
|
|
lHDCSave = CreateCompatibleDC(lHDCDest)
|
|
|
|
'Create a bitmap for each DC. DCs are required for
|
|
'a number of GDI functions
|
|
|
|
'Monochrome DC
|
|
lBmAndBack = CreateBitmap(x, y, 1&, 1&, 0&)
|
|
'Monochrome DC
|
|
lBmAndObject = CreateBitmap(x, y, 1&, 1&, 0&)
|
|
'Compatible DC's
|
|
lBmAndMem = CreateCompatibleBitmap(lHDCDest, x, y)
|
|
lBmSave = CreateCompatibleBitmap(lHDCDest, x, y)
|
|
|
|
'Each DC must select a bitmap object to store pixel data.
|
|
lBmBackOld = SelectObject(lHDCBack, lBmAndBack)
|
|
lBmObjectOld = SelectObject(lHDCObject, lBmAndObject)
|
|
lBmMemOld = SelectObject(lHDCMem, lBmAndMem)
|
|
lBmSaveOld = SelectObject(lHDCSave, lBmSave)
|
|
|
|
'Set proper mapping mode.
|
|
SetMapMode lHDCTemp, GetMapMode(lHDCDest)
|
|
|
|
'Save the bitmap sent here, because it will be overwritten
|
|
BitBlt lHDCSave, 0&, 0&, x, y, lHDCTemp, lSrcStartX, lSrcStartY, vbSrcCopy
|
|
|
|
'Set the background color of the source DC to the color
|
|
'contained in the parts of the bitmap that should be transparent
|
|
lColorRef = SetBkColor(lHDCTemp, lMaskColor)
|
|
|
|
'Create the object mask for the bitmap by performaing a BitBlt
|
|
'from the source bitmap to a monochrome bitmap.
|
|
BitBlt lHDCObject, 0&, 0&, x, y, lHDCTemp, lSrcStartX, lSrcStartY, vbSrcCopy
|
|
|
|
'Set the background color of the source DC back to the original color
|
|
SetBkColor lHDCTemp, lColorRef
|
|
|
|
'Create the inverse of the object mask.
|
|
BitBlt lHDCBack, 0&, 0&, x, y, lHDCObject, 0&, 0&, vbNotSrcCopy
|
|
|
|
'Copy the background of the main DC to the destination
|
|
If (BkGrndHdc <> 0) Then
|
|
BitBlt lHDCMem, 0&, 0&, x, y, BkGrndHdc, lDestStartX, lDestStartY, vbSrcCopy
|
|
Else
|
|
BitBlt lHDCMem, 0&, 0&, x, y, lHDCDest, lDestStartX, lDestStartY, vbSrcCopy
|
|
End If
|
|
|
|
'Mask out the places where the bitmap will be placed
|
|
BitBlt lHDCMem, 0&, 0&, x, y, lHDCObject, 0&, 0&, vbSrcAnd
|
|
|
|
'Mask out the transparent colored pixels on the bitmap
|
|
BitBlt lHDCTemp, lSrcStartX, lSrcStartY, x, y, lHDCBack, 0&, 0&, vbSrcAnd
|
|
|
|
'XOR the bitmap with the background on the destination DC
|
|
BitBlt lHDCMem, 0&, 0&, x, y, lHDCTemp, lSrcStartX, lSrcStartY, vbSrcPaint
|
|
|
|
'Copy the destination to the screen
|
|
BitBlt lHDCDest, lDestStartX, lDestStartY, x, y, lHDCMem, 0&, 0&, vbSrcCopy
|
|
|
|
'Place the original bitmap back into the bitmap sent here
|
|
BitBlt lHDCTemp, lSrcStartX, lSrcStartY, x, y, lHDCSave, 0&, 0&, vbSrcCopy
|
|
|
|
'Delete memory bitmaps
|
|
DeleteObject SelectObject(lHDCBack, lBmBackOld)
|
|
DeleteObject SelectObject(lHDCObject, lBmObjectOld)
|
|
DeleteObject SelectObject(lHDCMem, lBmMemOld)
|
|
DeleteObject SelectObject(lHDCSave, lBmSaveOld)
|
|
|
|
'Delete memory DC's
|
|
DeleteDC lHDCMem
|
|
DeleteDC lHDCBack
|
|
DeleteDC lHDCObject
|
|
DeleteDC lHDCSave
|
|
DeleteDC lHDCTemp
|
|
'-----------------------------------------------------------------
|
|
End Sub
|
|
'-----------------------------------------------------------------
|