'//
'// Name:clsTranparent.cls
'// Author:Q&f
'// Email:dengyu1230359@sina.com
'//
Option Explicit
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type BITMAP '14 bytes
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
bmBits As Long
End Type
'// BitBlt API dwRop parameter constants
Private Const SRCAND = &H8800C6 ' (DWORD) dest = source AND dest
Private Const SRCCOPY = &HCC0020 ' (DWORD) dest = source
Private Const SRCERASE = &H440328 ' (DWORD) dest = source AND (NOT dest )
Private Const SRCINVERT = &H660046 ' (DWORD) dest = source XOR dest
Private Const SRCPAINT = &HEE0086 ' (DWORD) dest = source OR dest
Private Const SRCMERGEPAINT = &HBB0226
Private Const SRCDSNA = &H220326
'// CombineRgn API nCombineMode parameter constants
Private Const RGN_AND = 1&
Private Const RGN_OR = 2&
Private Const RGN_XOR = 3&
Private Const RGN_DIFF = 4&
Private Const RGN_COPY = 5&
'// SetStretchBltMode API nStretchMode parameter constants
Private Const STRETCH_ANDSCANS = 1
Private Const STRETCH_ORSCANS = 2
Private Const STRETCH_DELETESCANS = 3
Private Const STRETCH_HALFTONE = 4
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function GetPixel Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function GetStretchBltMode Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function SetStretchBltMode Lib "gdi32" (ByVal hDC As Long, ByVal nStretchMode As Long) As Long
Private Declare Function StretchBlt Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Private Declare Function GetBkColor Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function SetBkColor Lib "gdi32" (ByVal hDC As Long, ByVal crColor 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 CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
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 SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetTextColor Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hDC As Long, ByVal crColor As Long) As Long
Private Declare Function FillRect Lib "user32" (ByVal hDC As Long, lpRect As RECT, ByVal hBrush As Long) As Integer
Private Declare Function DrawIcon Lib "user32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByVal hIcon As Long) As Long
Public Sub TransparentPaint(ByVal objFrmOrPic As Object, picSource As StdPicture, _
ByVal lngX As Long, ByVal lngY As Long, ByVal lngMaskColor As Long)
'This sub uses a bunch of variables,so let's declare and explain them in advance...
Dim lngSrcDC As Long 'Source bitmap
Dim lngSaveDC As Long 'Copy of Source bitmap
Dim lngMaskDC As Long 'Monochrome Mask bitmap
Dim lngInvDC As Long 'Monochrome Inverse of Mask bitmap
Dim lngNewPicDC As Long 'Combination of Source & Background bmps
Dim bmpSource As BITMAP 'Description of the Source bitmap
Dim hResultBmp As Long 'Combination of Source & Background
Dim hSaveBmp As Long 'Copy of Source bitmap
Dim hMaskBmp As Long 'Monochrome Mask bitmap
Dim hInvBmp As Long 'Monochrome Inverse of Mask bitmap
Dim hSrcPrevBmp As Long 'Holds prev bitmap in source DC
Dim hSavePrevBmp As Long 'Holds prev bitmap in saved DC
Dim hDestPrevBmp As Long 'Holds prev bitmap in destination DC
Dim hMaskPrevBmp As Long 'Holds prev bitmap in the mask DC
Dim hInvPrevBmp As Long 'Holds prev bitmap in inverted mask DC
Dim lngOrigScaleMode As Long 'Holds the original ScaleMode
Dim lngOrigColor As Long 'Holds original backcolor from source DC
'Set ScaleMode to pixels for Windows GDI
lngOrigScaleMode = objFrmOrPic.ScaleMode
objFrmOrPic.ScaleMode = vbPixels
'Load the source bitmap to get its width(bmpSource.bmWidth)
'and height(bmpSource.bmHeight)
GetObject picSource, Len(bmpSource), bmpSource
'Create compatible device contexts(DCs) to hold the temporary
'bitmaps used by this sub
lngSrcDC = CreateCompatibleDC(objFrmOrPic.hDC)
lngSaveDC = CreateCompatibleDC(objFrmOrPic.hDC)
lngMaskDC = CreateCompatibleDC(objFrmOrPic.hDC)
lngInvDC = CreateCompatibleDC(objFrmOrPic.hDC)
lngNewPicDC = CreateCompatibleDC(objFrmOrPic.hDC)
'Create monochrome bitmaps for the mask-related bitmaps
hMaskBmp = CreateBitmap(bmpSource.bmWidth, bmpSource.bmHeight, 1, 1, ByVal 0&)
hInvBmp = CreateBitmap(bmpSource.bmWidth, bmpSource.bmHeight, 1, 1, ByVal 0&)
'Create color bitmaps for the final result and the backup copy
'of the source bitmap
hResultBmp = CreateCompatibleBitmap(objFrmOrPic.hDC, bmpSource.bmWidth, bmpSource.bmHeight)
hSaveBmp = CreateCompatibleBitmap(objFrmOrPic.hDC, bmpSource.bmWidth, bmpSource.bmHeight)
'Select bitmap into the device context(DC)
hSrcPrevBmp = SelectObject(lngSrcDC, picSource)
hSavePrevBmp = SelectObject(lngSaveDC, hSaveBmp)
hMaskPrevBmp = SelectObject(lngMaskDC, hMaskBmp)
hInvPrevBmp = SelectObject(lngInvDC, hInvBmp)
hDestPrevBmp = SelectObject(lngNewPicDC, hResultBmp)
'Make a backup of source bitmap to restore later
BitBlt lngSaveDC, 0, 0, bmpSource.bmWidth, bmpSource.bmHeight, lngSrcDC, 0, 0, vbSrcCopy
'Create the mask by setting the background color of source to
'transparent color,then BitBlt'ing that bitmap into the mask
'device context(DC)
lngOrigColor = SetBkColor(lngSrcDC, lngMaskColor)
BitBlt lngMaskDC, 0, 0, bmpSource.bmWidth, bmpSource.bmHeight, lngSrcDC, 0, 0, vbSrcCopy
'Restore the original backcolor
SetBkColor lngSrcDC, lngOrigColor
'Cretate an inverse of the mask to and with the source and combine
'it with the background
BitBlt lngInvDC, 0, 0, bmpSource.bmWidth, bmpSource.bmHeight, lngMaskDC, 0, 0, vbNotSrcCopy
'Copy the background bitmap to the new picture device context
'to begin creating the final transparent bitmap
BitBlt lngNewPicDC, 0, 0, bmpSource.bmWidth, bmpSource.bmHeight, objFrmOrPic.hDC, lngX, lngY, vbSrcCopy
'AND the mask bitmap with the result device context to create
'a cookie cutter effect in the background by painting the black
'area for the non-transparent portion of the source bitmap
BitBlt lngNewPicDC, 0, 0, bmpSource.bmWidth, bmpSource.bmHeight, lngMaskDC, 0, 0, vbSrcAnd
'AND the inverse mask with the source bitmap to turn off the bits
'associated with transparent area of source bitmap by making it black
BitBlt lngSrcDC, 0, 0, bmpSource.bmWidth, bmpSource.bmHeight, lngInvDC, 0, 0, vbSrcAnd
'XOR the result with the source bitmap to replace the mask color
'with the background color
BitBlt lngNewPicDC, 0, 0, bmpSource.bmWidth, bmpSource.bmHeight, lngSrcDC, 0, 0, vbSrcPaint
'Paint the transparent bitmap on source surface
BitBlt objFrmOrPic.hDC, lngX, lngY, bmpSource.bmWidth, bmpSource.bmHeight, lngNewPicDC, 0, 0, vbSrcCopy
'Restore backup of bitmap
BitBlt lngSrcDC, 0, 0, bmpSource.bmWidth, bmpSource.bmHeight, lngSaveDC, 0, 0, vbSrcCopy
'Restore the original objects by selecting their original values
SelectObject lngSrcDC, hSrcPrevBmp
SelectObject lngSaveDC, hSavePrevBmp
SelectObject lngNewPicDC, hDestPrevBmp
SelectObject lngMaskDC, hMaskPrevBmp
SelectObject lngInvDC, hInvPrevBmp
'Free system resources created by this sub
DeleteObject hSaveBmp
DeleteObject hMaskBmp
DeleteObject hInvBmp
DeleteObject hResultBmp
DeleteDC lngSrcDC
DeleteDC lngSaveDC
DeleteDC lngInvDC
DeleteDC lngMaskDC
DeleteDC lngNewPicDC
'Restores the ScaleMode to its original value
objFrmOrPic.ScaleMode = lngOrigScaleMode
End Sub
Public Sub PaintTransparentDC(ByVal hdcDest As Long, ByVal xDest As Long, ByVal yDest As Long, _
ByVal Width As Long, ByVal Height As Long, _
ByVal hdcSrc As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal clrMaskColor As OLE_COLOR)
Dim hdcMask As Long 'HDC of the created mask image
Dim hdcColor As Long 'HDC of the created color image
Dim hbmMask As Long 'Bitmap handle to the mask image
Dim hbmColor As Long 'Bitmap handle to the color image
Dim hbmColorOld As Long
Dim hbmMaskOld As Long
Dim hdcScreen As Long
Dim hdcScnBuffer As Long 'Buffer to do all work on
Dim hbmScnBuffer As Long
Dim hbmScnBufferOld As Long
Dim hPalBufferOld As Long
hdcScreen = GetDC(0&)
'Create a color bitmap to server as a copy of the destination
'Do all work on this bitmap and then copy it back over the
'destination when it's done.
hbmScnBuffer = CreateCompatibleBitmap(hdcScreen, Width, Height)
'Create DC for screen buffer
hdcScnBuffer = CreateCompatibleDC(hdcScreen)
hbmScnBufferOld = SelectObject(hdcScnBuffer, hbmScnBuffer)
'Copy the destination to the screen buffer
BitBlt hdcScnBuffer, 0, 0, Width, Height, hdcDest, xDest, yDest, vbSrcCopy
'Create a (color) bitmap for the cover (can't use
'CompatibleBitmap with hdcSrc, because this will create a
'DIB section if the original bitmap is a DIB section)
hbmColor = CreateCompatibleBitmap(hdcScreen, Width, Height)
'Now create a monochrome bitmap for the mask
hbmMask = CreateBitmap(Width, Height, 1, 1, ByVal 0&)
'First, blt the source bitmap onto the cover. We do this
'first and then use it instead of the source bitmap
'because the source bitmap may be
'a DIB section, which behaves differently than a bitmap.
'(Specifically, copying from a DIB section to a monochrome
'bitmap does a nearest-color selection rather than painting
'based on the backcolor and forecolor.
hdcColor = CreateCompatibleDC(hdcScreen)
hbmColorOld = SelectObject(hdcColor, hbmColor)
'In case hdcSrc contains a monochrome bitmap, we must set
'the destination foreground/background colors according to
'those currently set in hdcSrc (because Windows will
'associate these colors with the two monochrome colors)
SetBkColor hdcColor, GetBkColor(hdcSrc)
SetTextColor hdcColor, GetTextColor(hdcSrc)
BitBlt hdcColor, 0, 0, Width, Height, hdcSrc, xSrc, ySrc, vbSrcCopy
'Paint the mask. What we want is white at the transparent
'color from the source, and black everywhere else.
hdcMask = CreateCompatibleDC(hdcScreen)
hbmMaskOld = SelectObject(hdcMask, hbmMask)
'When bitblt'ing from color to monochrome, Windows sets to 1
'all pixels that match the background color of the source DC.
'All other bits are set to 0.
SetBkColor hdcColor, clrMaskColor
SetTextColor hdcColor, vbWhite
BitBlt hdcMask, 0, 0, Width, Height, hdcColor, 0, 0, vbSrcCopy
'Paint the rest of the cover bitmap.
'
'What we want here is black at the transparent color,
'and the original colors everywhere else. To do this,
'we first paint the original onto the cover (which we
'already did), then we AND the inverse of the mask onto
'that using the SRCDSNA ternary raster operation
'(0x00220326 - see Win32 SDK reference, Appendix,
'"Raster Operation Codes", "Ternary
'Raster Operations", or search in MSDN for 00220326).
'SRCDSNA [reverse polish] means "(not SRC) and DEST".
'
'When bitblt'ing from monochrome to color, Windows
'transforms all white bits (1) to the background color
'of the destination hdc. All black (0)
'bits are transformed to the foreground color.
SetTextColor hdcColor, vbBlack
SetBkColor hdcColor, vbWhite
BitBlt hdcColor, 0, 0, Width, Height, hdcMask, 0, 0, SRCDSNA
'Paint the Mask to the Screen buffer
BitBlt hdcScnBuffer, 0, 0, Width, Height, hdcMask, 0, 0, vbSrcAnd
'Paint the Color to the Screen buffer
BitBlt hdcScnBuffer, 0, 0, Width, Height, hdcColor, 0, 0, vbSrcPaint
'Copy the screen buffer to the screen
BitBlt hdcDest, xDest, yDest, Width, Height, hdcScnBuffer, 0, 0, vbSrcCopy
'All done!
DeleteObject SelectObject(hdcColor, hbmColorOld)
DeleteDC hdcColor
DeleteObject SelectObject(hdcScnBuffer, hbmScnBufferOld)
DeleteDC hdcScnBuffer
DeleteObject SelectObject(hdcMask, hbmMaskOld)
DeleteDC hdcMask
ReleaseDC 0&, hdcScreen
End Sub
Public Sub PaintTransparentStdPic(ByVal hdcDest As Long, ByVal xDest As Long, ByVal yDest As Long, _
ByVal Width As Long, ByVal Height As Long, _
ByVal picSource As Picture, ByVal xSrc As Long, ByVal ySrc As Long, _
ByVal clrMaskColor As OLE_COLOR)
Dim hdcSrc As Long 'HDC for source bitmap
Dim hbmMemSrcOld As Long
Dim hbmMemSrc As Long
Dim udtRect As RECT
Dim hbrMask As Long
Dim hdcScreen As Long
'Verify that the passed picture is a Bitmap
If picSource Is Nothing Then Exit Sub
Select Case picSource.Type
Case vbPicTypeBitmap
hdcScreen = GetDC(0&)
'Select passed picture into an HDC
hdcSrc = CreateCompatibleDC(hdcScreen)
hbmMemSrcOld = SelectObject(hdcSrc, picSource.Handle)
'Draw the bitmap
PaintTransparentDC hdcDest, xDest, yDest, Width, Height, hdcSrc, xSrc, ySrc, clrMaskColor
SelectObject hdcSrc, hbmMemSrcOld
DeleteDC hdcSrc
ReleaseDC 0&, hdcScreen
Case vbPicTypeIcon
'Create a bitmap and select it into an DC
hdcScreen = GetDC(0&)
hdcSrc = CreateCompatibleDC(hdcScreen)
hbmMemSrc = CreateCompatibleBitmap(hdcScreen, Width, Height)
hbmMemSrcOld = SelectObject(hdcSrc, hbmMemSrc)
'Draw Icon onto DC
udtRect.Bottom = Height
udtRect.Right = Width
hbrMask = CreateSolidBrush(clrMaskColor)
FillRect hdcSrc, udtRect, hbrMask
DeleteObject hbrMask
DrawIcon hdcSrc, 0, 0, picSource.Handle
'Draw Transparent image
PaintTransparentDC hdcDest, xDest, yDest, Width, Height, hdcSrc, 0, 0, clrMaskColor
'Clean up
DeleteObject SelectObject(hdcSrc, hbmMemSrcOld)
DeleteDC hdcSrc
ReleaseDC 0&, hdcScreen
Case Else
End Select
End Sub
Public Sub CopyBitmapToDestWindow(ByVal hDestWnd As Long, picSource As StdPicture, _
ByVal lngX As Long, ByVal lngY As Long)
Dim hDestDC As Long
Dim hSrcDC As Long
Dim bmpSource As BITMAP
Dim hPrevBitmap As Long
hDestDC = GetDC(hDestWnd)
hSrcDC = CreateCompatibleDC(hDestDC)
hPrevBitmap = SelectObject(hSrcDC, picSource.Handle)
BitBlt hDestDC, lngX, lngY, picSource.Width, picSource.Height, hSrcDC, 0, 0, vbSrcCopy
SelectObject hSrcDC, hPrevBitmap
ReleaseDC hDestWnd, hDestDC
DeleteDC hSrcDC
End Sub
Public Sub CreateGraphWindow(objFrmOrPic As Object, Optional ByVal clrMaskColor As Long = 0)
Dim lWidth As Long
Dim lHeight As Long
Dim lx As Long, ly As Long
Dim hrRgn As Long
Dim hdRgn As Long
Dim hObjDC As Long
objFrmOrPic.AutoRedraw = True
objFrmOrPic.ScaleMode = vbPixels
lWidth = objFrmOrPic.ScaleWidth
lHeight = objFrmOrPic.ScaleHeight
hObjDC = GetDC(objFrmOrPic.hWnd)
hdRgn = CreateRectRgn(0, 0, 0, 0)
For lx = 0 To lWidth - 1
For ly = 0 To lHeight - 1
If GetPixel(hObjDC, lx, ly) <> clrMaskColor Then
hrRgn = CreateRectRgn(lx, ly, lx + 1, ly + 1)
If hrRgn Then
CombineRgn hdRgn, hdRgn, hrRgn, RGN_OR
DeleteObject hrRgn
End If
End If
Next
Next
SetWindowRgn objFrmOrPic.hWnd, hdRgn, True
ReleaseDC objFrmOrPic.hWnd, hObjDC
DeleteObject hdRgn
End Sub
Public Sub TransparentImage(dstFrmOrPic As Object, _
picSource As StdPicture, _
picMask As StdPicture, ByVal lngX As Long, ByVal lngY As Long)
Dim bmpSource As BITMAP
Dim hSourDC As Long
Dim hMaskDC As Long
dstFrmOrPic.AutoRedraw = True
dstFrmOrPic.ScaleMode = vbPixels
hSourDC = CreateCompatibleDC(dstFrmOrPic.hDC)
hMaskDC = CreateCompatibleDC(dstFrmOrPic.hDC)
SelectObject hSourDC, picSource
SelectObject hMaskDC, picMask
GetObject picSource, Len(bmpSource), bmpSource
BitBlt dstFrmOrPic.hDC, _
lngX, lngY, bmpSource.bmWidth, bmpSource.bmHeight, _
hMaskDC, 0, 0, SRCMERGEPAINT
BitBlt dstFrmOrPic.hDC, _
lngX, lngY, bmpSource.bmWidth, bmpSource.bmHeight, _
hSourDC, 0, 0, SRCAND
dstFrmOrPic.Refresh
DeleteDC hSourDC
DeleteDC hMaskDC
End Sub
Public Sub StretchPic(dstPic As PictureBox)
Dim lngOldDIB As Long
Dim lngOldMode As Long
Dim lnghDC As Long
Dim lngMHDC As Long
Dim lngSrcX As Long
Dim lngSrcY As Long
dstPic.AutoRedraw = True
dstPic.ScaleMode = vbPixels
lnghDC = GetDC(dstPic.hWnd)
lngMHDC = CreateCompatibleDC(lnghDC)
ReleaseDC dstPic.hWnd, lnghDC
lngSrcX = dstPic.ScaleX(dstPic.Picture.Width, vbHimetric, vbPixels)
lngSrcY = dstPic.ScaleY(dstPic.Picture.Height, vbHimetric, vbPixels)
lngOldDIB = SelectObject(lngMHDC, dstPic.Picture.Handle)
lngOldMode = SetStretchBltMode(dstPic.hDC, STRETCH_DELETESCANS)
StretchBlt dstPic.hDC, 0, 0, dstPic.ScaleWidth, dstPic.ScaleHeight, _
lngMHDC, 0, 0, lngSrcX, lngSrcY, vbSrcCopy
SetStretchBltMode dstPic.hDC, lngOldMode
dstPic.Refresh
SelectObject lngMHDC, lngOldDIB
DeleteObject lngOldDIB
DeleteDC lngMHDC
End Sub