vbAccelerator - Contents of code file: cTextureBrush.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "cTextureBrush"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

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 Type BITMAP
    bmType As Long
    bmWidth As Long
    bmHeight As Long
    bmWidthBytes As Long
    bmPlanes As Integer
    bmBitsPixel As Integer
    bmBits As Long
End Type
Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal
 hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
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
Private Declare Function OleTranslateColor Lib "OLEPRO32.DLL" (ByVal OLE_COLOR
 As Long, ByVal HPALETTE As Long, pccolorref As Long) As Long
Private Const CLR_INVALID = -1
Private Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal
 crColor As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal
 crColor As Long) As Long
Private Declare Function CreateDCAsNull Lib "gdi32" Alias "CreateDCA" (ByVal
 lpDriverName As String, lpDeviceName As Any, lpOutput As Any, lpInitData As
 Any) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) 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 CreateCompatibleDC Lib "gdi32" (ByVal hdc 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

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

Private m_hBrush As Long
Private m_lWidth As Long
Private m_lHeight As Long

Public Sub CreateFromPicture(picThis As IPicture)
   ' Create a copy of the bitmap:
   Dim lhDC As Long
   Dim lhDCCopy As Long
   Dim lhBmpCopy As Long
   Dim lhBmpCopyOld As Long
   Dim lhBmpOld As Long
   Dim lhDCC As Long
   Dim tBM As BITMAP
   
   GetObjectAPI picThis.Handle, Len(tBM), tBM
   lhDCC = CreateDCAsNull("DISPLAY", ByVal 0&, ByVal 0&, ByVal 0&)
   lhDC = CreateCompatibleDC(lhDCC)
   lhBmpOld = SelectObject(lhDC, picThis.Handle)
   
   lhDCCopy = CreateCompatibleDC(lhDCC)
   lhBmpCopy = CreateCompatibleBitmap(lhDCC, tBM.bmWidth, tBM.bmHeight)
   lhBmpCopyOld = SelectObject(lhDCCopy, lhBmpCopy)

   BitBlt lhDCCopy, 0, 0, tBM.bmWidth, tBM.bmHeight, lhDC, 0, 0, vbSrcCopy
   
   If Not (lhDCC = 0) Then
      DeleteDC lhDCC
   End If
   If Not (lhBmpOld = 0) Then
      SelectObject lhDC, lhBmpOld
   End If
   If Not (lhDC = 0) Then
      DeleteDC lhDC
   End If
   If Not (lhBmpCopyOld = 0) Then
      SelectObject lhDCCopy, lhBmpCopyOld
   End If
   If Not (lhDCCopy = 0) Then
      DeleteDC lhDCCopy
   End If
   
   CreateFromHBitmap lhBmpCopy
   
   DeleteObject lhBmpCopy
   
   
End Sub
Public Sub CreateFromDC(ByVal lhDC As Long, ByVal lWidth As Long, ByVal lHeight
 As Long)
   ' Copy the bitmap in lHDC:
   Dim lhDCCopy As Long
   Dim lhBmpCopy As Long
   Dim lhBmpCopyOld As Long
   Dim lhDCC As Long
   Dim tBM As BITMAP
   
   lhDCC = CreateDCAsNull("DISPLAY", ByVal 0&, ByVal 0&, ByVal 0&)
   lhDCCopy = CreateCompatibleDC(lhDCC)
   lhBmpCopy = CreateCompatibleBitmap(lhDCC, lWidth, lHeight)
   lhBmpCopyOld = SelectObject(lhDCCopy, lhBmpCopy)
   
   BitBlt lhDCCopy, 0, 0, lWidth, lHeight, lhDC, 0, 0, vbSrcCopy
   
   If Not (lhDCC = 0) Then
      DeleteDC lhDCC
   End If
   If Not (lhBmpCopyOld = 0) Then
      SelectObject lhDCCopy, lhBmpCopyOld
   End If
   If Not (lhDCCopy = 0) Then
      DeleteDC lhDCCopy
   End If
   
   CreateFromHBitmap lhBmpCopy
   
   DeleteObject lhBmpCopy
   
End Sub

Public Sub CreateFromHBitmap(ByVal hBmp As Long)
   
   Destroy
   
   Dim tBM As BITMAP
   GetObjectAPI hBmp, Len(tBM), tBM
   m_hBrush = CreatePatternBrush(hBmp)
   m_lWidth = tBM.bmWidth
   m_lHeight = tBM.bmHeight
   
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, _
      Optional ByVal oBackColor As OLE_COLOR = -1, _
      Optional ByVal oForeColor As OLE_COLOR = -1 _
   )
Dim hOldBrush As Long
Dim lBkColor As Long
Dim lForeColor As Long
   hOldBrush = SelectObject(hdc, m_hBrush)
      If Not (oBackColor = -1) Then
         lBkColor = SetBkColor(hdc, TranslateColor(oBackColor))
      End If
      If Not (oForeColor = -1) Then
         lForeColor = SetTextColor(hdc, TranslateColor(oForeColor))
      End If
   PatBlt hdc, xPixels, yPixels, widthPixels, heightPixels, eRop
   If Not (oBackColor = -1) Then
      SetBkColor hdc, lBkColor
   End If
   If Not (oForeColor = -1) Then
       SetTextColor hdc, lForeColor
   End If
   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, _
      Optional ByVal oBackColor As OLE_COLOR = -1, _
      Optional ByVal oForeColor As OLE_COLOR = -1 _
   )
Dim lBkColor As Long
Dim lForeColor As Long

   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)
      If Not (oBackColor = -1) Then
         lBkColor = SetBkColor(hdc, TranslateColor(oBackColor))
      End If
      If Not (oForeColor = -1) Then
         lForeColor = SetTextColor(hdc, TranslateColor(oForeColor))
      End If
      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
      If Not (oBackColor = -1) Then
         SetBkColor hdc, lBkColor
      End If
      If Not (oForeColor = -1) Then
          SetTextColor hdc, lForeColor
      End If
      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 m_lWidth, -yPixels And m_lHeight, ByVal 0&
End Sub

Private Function TranslateColor(ByVal oClr As OLE_COLOR, _
                        Optional hPal As Long = 0) As Long
    ' Convert Automation color to Windows color
    If OleTranslateColor(oClr, hPal, TranslateColor) Then
        TranslateColor = CLR_INVALID
    End If
End Function
Public Sub Destroy()
   If m_hBrush <> 0 Then
      DeleteObject m_hBrush
      m_hBrush = 0
   End If
End Sub

Private Sub Class_Terminate()
   Destroy
End Sub