vbAccelerator - Contents of code file: cDottedBrush.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "cDottedBrush"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

'
 ===============================================================================
================
' vbAccelerator
' http://vbaccelerator.com/
'  1999 Steve McMahon (steve@vbaccelerator.com)
'
' cDottedBrush
' Allows drawing of correct dotted brushes like the ones in the TreeView.
'
' Based on an article "Drawing Dotted Lines" by Jean-Edouard Lachand-Robert
 published
' at CodeGuru (http://www.codeguru.com/)
'
 ===============================================================================
================

Private Type BITMAP '24 bytes
   bmType As Long
   bmWidth As Long
   bmHeight As Long
   bmWidthBytes As Long
   bmPlanes As Integer
   bmBitsPixel As Integer
   bmBits As Long
End Type
Private Type POINTAPI
   x As Long
   y As Long
End Type
Private Type RECT
   Left As Long
   Top As Long
   Right As Long
   Bottom As Long
End Type
Private Declare Function SetBrushOrgEx Lib "gdi32" (ByVal hDC As Long, ByVal
 nXOrg As Long, ByVal nYOrg As Long, lppt As Any) As Long
Private Declare Function UnrealizeObject Lib "gdi32" (ByVal hObject 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 PatBlt Lib "gdi32" (ByVal hDC As Long, ByVal x As
 Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal
 dwRop As Long) As Long
Private Declare Function CreateBitmapIndirect Lib "gdi32" (lpBitmap As BITMAP)
 As Long
Private Declare Function CreatePatternBrush Lib "gdi32" (ByVal hBitmap As Long)
 As Long
Private Declare Function FillRect Lib "user32" (ByVal hDC As Long, lpRect As
 RECT, ByVal hBrush As Long) As Long

Public Enum EPBRasterOperations
   PATCOPY = &HF00021  ' (DWORD) dest = pattern
   PATINVERT = &H5A0049        ' (DWORD) dest = pattern XOR dest
   PATPAINT = &HFB0A09        ' (DWORD) dest = DPSnoo
End Enum

' The brush:
Private m_hBrush As Long
' The brush's pattern:
Private m_lPattern(0 To 3) As Long

Public Function Create() As Boolean
Dim tBM As BITMAP
Dim hBm As Long

   Destroy
      
   ' Create a monochrome bitmap containing the desired pattern:
   tBM.bmType = 0
   tBM.bmWidth = 16
   tBM.bmHeight = 8
   tBM.bmWidthBytes = 2
   tBM.bmPlanes = 1
   tBM.bmBitsPixel = 1
   tBM.bmBits = VarPtr(m_lPattern(0))
   hBm = CreateBitmapIndirect(tBM)

   ' Make a brush from the bitmap bits
   m_hBrush = CreatePatternBrush(hBm)

   '// Delete the useless bitmap
   DeleteObject hBm

End Function

Public Sub Destroy()
   If m_hBrush <> 0 Then
      DeleteObject m_hBrush
   End If
End Sub

Public Sub DrawLine( _
      ByVal hDC As Long, _
      ByVal xPixels As Long, _
      ByVal yPixels As Long, _
      ByVal widthPixels As Long, _
      ByVal heightPixels As Long, _
      Optional ByVal eRop As EPBRasterOperations = PATCOPY _
   )
Dim hOldBrush As Long
   hOldBrush = SelectObject(hDC, m_hBrush)
   PatBlt hDC, xPixels, yPixels, widthPixels, heightPixels, eRop
   SelectObject hDC, hOldBrush
End Sub
Public Sub Rectangle( _
      ByVal hDC As Long, _
      ByVal xPixels As Long, _
      ByVal yPixels As Long, _
      ByVal widthRectPixels As Long, _
      ByVal heightRectPixels As Long, _
      ByVal lineSizePixels As Long, _
      Optional ByVal eRop As EPBRasterOperations = PATCOPY, _
      Optional ByVal bFill As Boolean = False _
   )
   If bFill Then
      Dim tR As RECT
      tR.Left = xPixels: tR.Top = xPixels
      tR.Right = tR.Left + widthRectPixels: tR.Bottom = tR.Top +
       heightRectPixels
      FillRect hDC, tR, m_hBrush
   Else
      Dim hOldBrush As Long
      hOldBrush = SelectObject(hDC, m_hBrush)
      PatBlt hDC, xPixels, yPixels, widthRectPixels, lineSizePixels, eRop
      PatBlt hDC, xPixels + widthRectPixels, yPixels, lineSizePixels,
       heightRectPixels, eRop
      PatBlt hDC, xPixels, yPixels + heightRectPixels, widthRectPixels,
       lineSizePixels, eRop
      PatBlt hDC, xPixels, yPixels, lineSizePixels, heightRectPixels, eRop
      SelectObject hDC, hOldBrush
   End If
End Sub
   
Public Sub SetBrushOrigin( _
      ByVal hDC As Long, _
      ByVal xPixels As Long, _
      ByVal yPixels As Long _
   )
   SetBrushOrgEx hDC, -xPixels And &H7&, -yPixels And &H7&, ByVal 0&
End Sub


Private Sub Class_Initialize()
Dim i As Long
   For i = 0 To 3
      m_lPattern(i) = &HAAAA5555
   Next i
End Sub

Private Sub Class_Terminate()
   Destroy
End Sub