pcMemDC.cls
上传用户:jnjasmy
上传日期:2015-01-04
资源大小:637k
文件大小:13k
源码类别:

GDI/图象编程

开发平台:

Visual Basic

  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4.   Persistable = 0  'NotPersistable
  5.   DataBindingBehavior = 0  'vbNone
  6.   DataSourceBehavior  = 0  'vbNone
  7.   MTSTransactionMode  = 0  'NotAnMTSObject
  8. END
  9. Attribute VB_Name = "pcMemDC"
  10. Attribute VB_GlobalNameSpace = False
  11. Attribute VB_Creatable = True
  12. Attribute VB_PredeclaredId = False
  13. Attribute VB_Exposed = False
  14. Option Explicit
  15. ' cMemDC - flicker free drawing
  16. '--- Raster Operation Codes
  17. Private Const DSna                      As Long = &H220326
  18. Private Type BITMAP
  19.     bmType As Long
  20.     bmWidth As Long
  21.     bmHeight As Long
  22.     bmWidthBytes As Long
  23.     bmPlanes As Long
  24.     bmBitsPixel As Integer
  25.     bmBits As Long
  26. End Type
  27. Private Type RGBTRIPLE
  28.         rgbBlue As Byte
  29.         rgbGreen As Byte
  30.         rgbRed As Byte
  31. End Type
  32. Private Type PALETTEENTRY
  33.     peRed               As Byte
  34.     peGreen             As Byte
  35.     peBlue              As Byte
  36.     peFlags             As Byte
  37. End Type
  38. Private Type LOGPALETTE
  39.     palVersion          As Integer
  40.     palNumEntries       As Integer
  41.     palPalEntry(255)    As PALETTEENTRY
  42. End Type
  43. Private Declare Function GetTextColor Lib "gdi32" (ByVal hDC As Long) As Long
  44. Private Declare Function SetTextColor Lib "gdi32" (ByVal hDC As Long, ByVal crColor As Long) As Long
  45. Private Declare Function GetBkColor Lib "gdi32" (ByVal hDC As Long) As Long
  46. Private Declare Function SetBkColor Lib "gdi32" (ByVal hDC As Long, ByVal crColor As Long) As Long
  47. Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
  48. Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
  49. Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
  50. Private Declare Function CreateDCAsNull Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, _
  51.            lpDeviceName As Any, lpOutput As Any, lpInitData As Any) As Long
  52. Private Declare Function CreateDC Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As Any) As Long
  53. Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
  54. Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
  55. Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
  56. Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long
  57. 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
  58. 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
  59. Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
  60. Private Declare Function SetDIBitsToDevice Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByVal dx As Long, ByVal dy As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal Scan As Long, ByVal NumScans As Long, Bits As Any, BitsInfo As BITMAPINFO, ByVal wUsage As Long) As Long
  61. Private Declare Function CreateHalftonePalette Lib "gdi32" (ByVal hDC As Long) As Long
  62. Private Declare Function CreatePalette Lib "gdi32" (lpLogPalette As LOGPALETTE) As Long
  63. Private Declare Function RealizePalette Lib "gdi32" (ByVal hDC As Long) As Long
  64. Private Declare Function SelectPalette Lib "gdi32" (ByVal hDC As Long, ByVal hPalette As Long, ByVal bForceBackground As Long) As Long
  65. 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
  66. Private m_hDC As Long
  67. Private m_hBmp As Long
  68. Private m_hBmpOld As Long
  69. Private m_lWidth As Long
  70. Private m_lHeight As Long
  71. Public Property Get Width() As Long
  72.    Width = m_lWidth
  73. End Property
  74. Public Property Let Width(ByVal Value As Long)
  75. Dim lJunk As Long
  76.    If (Value > m_lWidth) Then
  77.       m_lWidth = Value
  78.       pCreate m_lWidth, m_lHeight
  79.    End If
  80. End Property
  81. Public Property Get Height() As Long
  82.    Height = m_lHeight
  83. End Property
  84. Public Property Let Height(ByVal Value As Long)
  85. Dim lJunk As Long
  86.    If (Value > m_lHeight) Then
  87.       m_lHeight = Value
  88.       pCreate m_lWidth, m_lHeight
  89.    End If
  90. End Property
  91. Public Property Get hDC() As Long
  92.    hDC = m_hDC
  93. End Property
  94. Public Sub StretchDraw( _
  95.       ByVal hDC As Long, _
  96.       Optional ByVal xDst As Long = 0, Optional ByVal yDst As Long = 0, _
  97.       Optional ByVal WidthDst As Long = 0, Optional ByVal HeightDst As Long = 0, _
  98.       Optional ByVal xSrc As Long = 0, Optional ByVal ySrc As Long = 0, _
  99.       Optional ByVal WidthSrc As Long = 0, Optional ByVal HeightSrc As Long = 0 _
  100.    )
  101.    If WidthSrc <= 0 Then WidthSrc = m_lWidth
  102.    If HeightSrc <= 0 Then HeightSrc = m_lHeight
  103.    StretchBlt hDC, xDst, yDst, WidthDst, HeightDst, m_hDC, xSrc, ySrc, WidthSrc, HeightSrc, vbSrcCopy
  104. End Sub
  105. Public Sub Draw( _
  106.       ByVal hDC As Long, _
  107.       Optional ByVal xSrc As Long = 0, Optional ByVal ySrc As Long = 0, _
  108.       Optional ByVal WidthSrc As Long = 0, Optional ByVal HeightSrc As Long = 0, _
  109.       Optional ByVal xDst As Long = 0, Optional ByVal yDst As Long = 0, _
  110.       Optional ByVal UseMask As Boolean _
  111.    )
  112.   If WidthSrc <= 0 Then WidthSrc = m_lWidth
  113.   If HeightSrc <= 0 Then HeightSrc = m_lHeight
  114.   If UseMask Then
  115.     pvTransBlt hDC, xDst, yDst, WidthSrc, HeightSrc, m_hDC, xSrc, ySrc
  116.   Else
  117.     BitBlt hDC, xDst, yDst, WidthSrc, HeightSrc, m_hDC, xSrc, ySrc, vbSrcCopy
  118.   End If
  119. End Sub
  120. Public Sub CreateFromPicture(sPic As IPicture)
  121. Dim tB As BITMAP
  122. Dim lhDCC As Long, lhDC As Long
  123. Dim lhBmpOld As Long
  124.    GetObjectAPI sPic.Handle, Len(tB), tB
  125.    Width = tB.bmWidth
  126.    Height = tB.bmHeight
  127.    lhDCC = CreateDCAsNull("DISPLAY", ByVal 0&, ByVal 0&, ByVal 0&)
  128.    lhDC = CreateCompatibleDC(lhDCC)
  129.    lhBmpOld = SelectObject(lhDC, sPic.Handle)
  130.    BitBlt m_hDC, 0, 0, tB.bmWidth, tB.bmHeight, lhDC, 0, 0, vbSrcCopy
  131.    SelectObject lhDC, lhBmpOld
  132.    DeleteDC lhDC
  133.    DeleteDC lhDCC
  134. End Sub
  135. Private Sub pCreate(ByVal Width As Long, ByVal Height As Long)
  136. Dim lhDCC As Long
  137.    pDestroy
  138.    lhDCC = CreateDC("DISPLAY", "", "", ByVal 0&)
  139.    If Not (lhDCC = 0) Then
  140.       m_hDC = CreateCompatibleDC(lhDCC)
  141.       If Not (m_hDC = 0) Then
  142.          m_hBmp = CreateCompatibleBitmap(lhDCC, Width, Height)
  143.          If Not (m_hBmp = 0) Then
  144.             m_hBmpOld = SelectObject(m_hDC, m_hBmp)
  145.             If Not (m_hBmpOld = 0) Then
  146.                m_lWidth = Width
  147.                m_lHeight = Height
  148.                DeleteDC lhDCC
  149.                Exit Sub
  150.             End If
  151.          End If
  152.       End If
  153.       DeleteDC lhDCC
  154.       pDestroy
  155.    End If
  156. End Sub
  157. Private Sub pDestroy()
  158.    If Not m_hBmpOld = 0 Then
  159.       SelectObject m_hDC, m_hBmpOld
  160.       m_hBmpOld = 0
  161.    End If
  162.    If Not m_hBmp = 0 Then
  163.       DeleteObject m_hBmp
  164.       m_hBmp = 0
  165.    End If
  166.    If Not m_hDC = 0 Then
  167.       DeleteDC m_hDC
  168.       m_hDC = 0
  169.    End If
  170.    m_lWidth = 0
  171.    m_lHeight = 0
  172. End Sub
  173. Private Sub Class_Terminate()
  174.    pDestroy
  175. End Sub
  176. Private Sub pvTransBlt( _
  177.             ByVal hdcDest As Long, _
  178.             ByVal xDest As Long, _
  179.             ByVal yDest As Long, _
  180.             ByVal nWidth As Long, _
  181.             ByVal nHeight As Long, _
  182.             ByVal hdcSrc As Long, _
  183.             Optional ByVal xSrc As Long = 0, _
  184.             Optional ByVal ySrc As Long = 0, _
  185.             Optional ByVal clrMask As OLE_COLOR = vbMagenta, _
  186.             Optional ByVal hPal As Long = 0)
  187.     Dim hdcMask             As Long ' hDC of the created mask image
  188.     Dim hdcColor            As Long ' hDC of the created color image
  189.     Dim hbmMask             As Long ' Bitmap handle to the mask image
  190.     Dim hbmColor            As Long ' Bitmap handle to the color image
  191.     Dim hbmColorOld         As Long
  192.     Dim hbmMaskOld          As Long
  193.     Dim hpalOld             As Long
  194.     Dim hdcScreen           As Long
  195.     Dim hdcScnBuffer        As Long ' Buffer to do all work on
  196.     Dim hbmScnBuffer        As Long
  197.     Dim hbmScnBufferOld     As Long
  198.     Dim hPalBufferOld       As Long
  199.     Dim lMaskColor          As Long
  200.     Dim hpalHalftone        As Long
  201.     hdcScreen = GetDC(0&)
  202.     ' Validate palette
  203.     If hPal = 0 Then
  204.         hpalHalftone = CreateHalftonePalette(hdcScreen)
  205.         hPal = hpalHalftone
  206.     End If
  207.     OleTranslateColor clrMask, hPal, lMaskColor
  208.     lMaskColor = lMaskColor And &HFFFFFF
  209.     ' Create a color bitmap to server as a copy of the destination
  210.     ' Do all work on this bitmap and then copy it back over the destination
  211.     ' when it's done.
  212.     hbmScnBuffer = CreateCompatibleBitmap(hdcScreen, nWidth, nHeight)
  213.     ' Create DC for screen buffer
  214.     hdcScnBuffer = CreateCompatibleDC(hdcScreen)
  215.     hbmScnBufferOld = SelectObject(hdcScnBuffer, hbmScnBuffer)
  216.     hPalBufferOld = SelectPalette(hdcScnBuffer, hPal, True)
  217.     RealizePalette hdcScnBuffer
  218.     ' Copy the destination to the screen buffer
  219.     BitBlt hdcScnBuffer, 0, 0, nWidth, nHeight, hdcDest, xDest, yDest, vbSrcCopy
  220.     ' Create a (color) bitmap for the cover (can't use CompatibleBitmap with
  221.     ' hdcSrc, because this will create a DIB section if the original bitmap
  222.     ' is a DIB section)
  223.     hbmColor = CreateCompatibleBitmap(hdcScreen, nWidth, nHeight)
  224.     ' Now create a monochrome bitmap for the mask
  225.     hbmMask = CreateBitmap(nWidth, nHeight, 1, 1, ByVal 0&)
  226.     ' First, blt the source bitmap onto the cover.  We do this first
  227.     ' and then use it instead of the source bitmap
  228.     ' because the source bitmap may be
  229.     ' a DIB section, which behaves differently than a bitmap.
  230.     ' (Specifically, copying from a DIB section to a monochrome bitmap
  231.     ' does a nearest-color selection rather than painting based on the
  232.     ' backcolor and forecolor.
  233.     hdcColor = CreateCompatibleDC(hdcScreen)
  234.     hbmColorOld = SelectObject(hdcColor, hbmColor)
  235.     hpalOld = SelectPalette(hdcColor, hPal, True)
  236.     RealizePalette hdcColor
  237.     ' In case hdcSrc contains a monochrome bitmap, we must set the destination
  238.     ' foreground/background colors according to those currently set in hdcSrc
  239.     ' (because Windows will associate these colors with the two monochrome colors)
  240.     Call SetBkColor(hdcColor, GetBkColor(hdcSrc))
  241.     Call SetTextColor(hdcColor, GetTextColor(hdcSrc))
  242.     Call BitBlt(hdcColor, 0, 0, nWidth, nHeight, hdcSrc, xSrc, ySrc, vbSrcCopy)
  243.     ' Paint the mask.  What we want is white at the transparent color
  244.     ' from the source, and black everywhere else.
  245.     hdcMask = CreateCompatibleDC(hdcScreen)
  246.     hbmMaskOld = SelectObject(hdcMask, hbmMask)
  247.     ' When BitBlt'ing from color to monochrome, Windows sets to 1
  248.     ' all pixels that match the background color of the source DC.  All
  249.     ' other bits are set to 0.
  250.     Call SetBkColor(hdcColor, lMaskColor)
  251.     Call SetTextColor(hdcColor, vbWhite)
  252.     Call BitBlt(hdcMask, 0, 0, nWidth, nHeight, hdcColor, 0, 0, vbSrcCopy)
  253.     ' Paint the rest of the cover bitmap.
  254.     '
  255.     ' What we want here is black at the transparent color, and
  256.     ' the original colors everywhere else.  To do this, we first
  257.     ' paint the original onto the cover (which we already did), then we
  258.     ' AND the inverse of the mask onto that using the DSna ternary raster
  259.     ' operation (0x00220326 - see Win32 SDK reference, Appendix, "Raster
  260.     ' Operation Codes", "Ternary Raster Operations", or search in MSDN
  261.     ' for 00220326).  DSna [reverse polish] means "(not SRC) and DEST".
  262.     '
  263.     ' When BitBlt'ing from monochrome to color, Windows transforms all white
  264.     ' bits (1) to the background color of the destination hDC.  All black (0)
  265.     ' bits are transformed to the foreground color.
  266.     Call SetTextColor(hdcColor, vbBlack)
  267.     Call SetBkColor(hdcColor, vbWhite)
  268.     Call BitBlt(hdcColor, 0, 0, nWidth, nHeight, hdcMask, 0, 0, DSna)
  269.     ' Paint the Mask to the Screen buffer
  270.     Call BitBlt(hdcScnBuffer, 0, 0, nWidth, nHeight, hdcMask, 0, 0, vbSrcAnd)
  271.     ' Paint the Color to the Screen buffer
  272.     Call BitBlt(hdcScnBuffer, 0, 0, nWidth, nHeight, hdcColor, 0, 0, vbSrcPaint)
  273.     ' Copy the screen buffer to the screen
  274.     Call BitBlt(hdcDest, xDest, yDest, nWidth, nHeight, hdcScnBuffer, 0, 0, vbSrcCopy)
  275.     ' All done!
  276.     Call DeleteObject(SelectObject(hdcColor, hbmColorOld))
  277.     Call SelectPalette(hdcColor, hpalOld, True)
  278.     Call RealizePalette(hdcColor)
  279.     Call DeleteDC(hdcColor)
  280.     Call DeleteObject(SelectObject(hdcScnBuffer, hbmScnBufferOld))
  281.     Call SelectPalette(hdcScnBuffer, hPalBufferOld, 0)
  282.     Call RealizePalette(hdcScnBuffer)
  283.     Call DeleteDC(hdcScnBuffer)
  284.     Call DeleteObject(SelectObject(hdcMask, hbmMaskOld))
  285.     Call DeleteDC(hdcMask)
  286.     Call ReleaseDC(0&, hdcScreen)
  287.     If hpalHalftone <> 0 Then
  288.         Call DeleteObject(hpalHalftone)
  289.     End If
  290. End Sub