bitbrush.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 = "BitBrush"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private Type BITMAPINFOHEADER
    biSize As Long
    biWidth As Long
    biHeight As Long
    biPlanes As Integer
    biBitCount As Integer
    biCompression As Long
    biSizeImage As Long
    biXPelsPerMeter As Long
    biYPelsPerMeter As Long
    biClrUsed As Long
    biClrImportant As Long
End Type

Private Type RGBQUAD
    rgbBlue As Byte
    rgbGreen As Byte
    rgbRed As Byte
    rgbReserved As Byte
End Type

Private Type BITMAPINFO
    bmiHeader As BITMAPINFOHEADER
    bmiColors(1) As RGBQUAD
End Type

Private Declare Function SelectObject& Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long)
Private Declare Function CreateDIBitmap& Lib "gdi32" (ByVal hDC As Long, lpInfoHeader As BITMAPINFOHEADER, ByVal dwUsage As Long, lpInitBits As Any, lpInitInfo As BITMAPINFO, ByVal wUsage As Long)
Private Declare Function DeleteObject& Lib "gdi32" (ByVal hObject As Long)
Private Declare Function CreatePatternBrush& Lib "gdi32" (ByVal hBitmap 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)

Private Const DIB_RGB_COLORS& = 0              '颜色表包含了RGB颜色
Private Const CBM_INIT& = &H4                  '对位图进行初始化
Private Const PATCOPY& = &HF00021
Private Const BI_RGB& = 0&                     '


Dim m_BitInfoH As BITMAPINFOHEADER
Dim m_BitInfo As BITMAPINFO


Dim da(32) As Byte
Dim m_Hbr As Long                 '画刷句柄
Dim m_OldBP As Long               '原来的画刷句柄

Private m_DispPict As Object      '被操纵的设备对象，如 PictureBox
Private m_Array(8) As String * 8

'属性
Public Property Set DispPict(Acontrol As Object)
     Set m_DispPict = Acontrol
End Property

Public Sub SetuBitmap(r1, g1, b1, r2, g2, b2)
    m_BitInfoH.biSize = 40
    m_BitInfoH.biWidth = 8
    m_BitInfoH.biHeight = 8
    
    m_BitInfoH.biPlanes = 1           '必须为1
    m_BitInfoH.biBitCount = 1          '单色(黑白)
    m_BitInfoH.biCompression = BI_RGB  '不压缩
    
    m_BitInfoH.biSizeImage = 0
    m_BitInfoH.biXPelsPerMeter = 0     'notused
    m_BitInfoH.biYPelsPerMeter = 0     'NotUsed
    m_BitInfoH.biClrUsed = 2
    m_BitInfoH.biClrImportant = 0
      '设置颜色
    m_BitInfo.bmiColors(0).rgbBlue = r1
    m_BitInfo.bmiColors(0).rgbGreen = g1
    m_BitInfo.bmiColors(0).rgbRed = b1
    m_BitInfo.bmiColors(0).rgbReserved = 1
    
    m_BitInfo.bmiColors(1).rgbBlue = r2
    m_BitInfo.bmiColors(1).rgbGreen = g2
    m_BitInfo.bmiColors(1).rgbRed = b2
    m_BitInfo.bmiColors(1).rgbReserved = 0
 
End Sub

'创建一副DIB位图刷子
Public Sub BuildBitmap()
    Dim Counter As Integer, V As Integer, C As Integer
    Dim CompBitmap As Long
    Dim dl As Long
    
    For Counter = 1 To 8
        V = 0

        For C = 0 To 7
            If Mid$(m_Array(Counter), C + 1, 1) = "1" Then V = V + 2 ^ C

        Next C
        da(Counter * 4 - 4) = CByte(V)
    Next Counter

    m_BitInfo.bmiHeader = m_BitInfoH
    CompBitmap = CreateDIBitmap(m_DispPict.hDC, m_BitInfoH, CBM_INIT, da(0), _
                                        m_BitInfo, DIB_RGB_COLORS)
    m_Hbr = CreatePatternBrush(CompBitmap)
    dl& = DeleteObject(CompBitmap)
End Sub

Public Sub DeleteBrush()
    Dim throw As Long
    throw& = SelectObject(m_DispPict.hDC, m_OldBP)
    throw& = DeleteObject(m_Hbr)
End Sub

Public Sub SelectBrush()
   m_OldBP = SelectObject(m_DispPict.hDC, m_Hbr)
End Sub

Public Sub ShowPattern()
    Dim throw As Long
    
    m_OldBP = SelectObject(m_DispPict.hDC, m_Hbr)
    throw& = PatBlt(m_DispPict.hDC, 0, 0, m_DispPict.ScaleWidth, m_DispPict.ScaleHeight, PATCOPY)
    throw& = SelectObject(m_DispPict.hDC, m_OldBP)
    throw& = DeleteObject(m_Hbr)
    
End Sub

Public Sub SetPattern(s, index)
    m_Array(index) = s
End Sub

Private Sub Class_Initialize()
    If m_Hbr Then DeleteBrush
End Sub