VB中透明图象的实现

'//
'// Name:clsTranparent.cls
'// Author:Q&f
'// Email:[e-mail]
'//

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