?? 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
?? 快捷鍵說明
復制代碼
Ctrl + C
搜索代碼
Ctrl + F
全屏模式
F11
切換主題
Ctrl + Shift + D
顯示快捷鍵
?
增大字號
Ctrl + =
減小字號
Ctrl + -