|
A Simplest way to create a customer
Pattern Brush in Visual Basic
To create a customer
brush only using the VB 6.0 Point() and Pset() function or VB
Net GetPixel() and SetPixels meshods will discuss hereafter. In
this article you will learn “How to create a color pattern brush
in a simplest and easiest way”. Using Api function we can create
a two color(white and black) bitmap brush by CreateBitmap()
function or a color bitmap brush by CreateCompatibleBitmap()
function. Using CreateBitmap() you should declare this function
first.
Private Declare Function
CreateBitmap Lib "gdi32" ( _
ByVal nWidth As Long,
ByVal nHeight As Long, ByVal nPlanes _
As Long, ByVal nBitCount
As Long, lpBits As Integer) As Long
The CreateBitmap
function creates a bitmap with the specified width, height, and
color format (color planes and bits per pixel).
nWidth: the width of bitmap
nHeight: the height of bitmap
nPlanes: the color plane of bitmap(1)
nBitCount: bits per pixel
lpBits: the array data of bitmap, only the
first one is enough.
A then using
CreatePatternBruh to create a patternBrush to fill a closed
area.
The pattern shown as
following,You must build a bitmap data array
Patterns(0 to 7) to save
the bitmap data. You can declare the data type as byte or
Integer.
If we use “1” to
represent the blank (white color) and “0” for solid(black
color). Since the first row is blank, it means all grids in
first row are fill with blank, i.e (1,1,1,1,1,1,1,1)
Since (1*2^7+ 1*2^6+
1*2^5+1*2^4+ 1*2^3+ 1*2^2+1*2^1+ 1*2^0)=255,then Pattern(0)=255.
If we declare Pattern(0
to 7) as Byte ,then the bitmap data will look like
Pattern(0)=255 or
Pattern(0)=&HFF or Pattern(0)=ox377
Pattern(1)=191 or
Pattern(1)=&HBF or Pattern(1)=ox277
Pattern(2)=223 or
Pattern(2)=&HFF or Pattern(2)=ox337
Pattern(3)=239 or
Pattern(3)=&HBF or Pattern(3)=ox357
Pattern(4)=247 or
Pattern(4)=&HFF or Pattern(4)=ox367
Pattern(5)=251 or
Pattern(5)=&HBF or Pattern(5)=ox373
Pattern(6)=253 or
Pattern(6)=&HFF or Pattern(6)=ox375
Pattern(7)=254 or
Pattern(7)=&HBF or Pattern(7)=ox276
If we declare Pattern(0
to 7) as String ,then the bitmap data will look like
Pattern(0)=”1,1,1,1,1,1,1,1”
Pattern(1)=”1,0,1,1,1,1,1,1”
.
.
Pattern(7)=”1,1,1,1,1,1,1,0”
If we add a
PictureBox named as PicContainer to a Form for drawing of pixel
replication, and a PictureBox named as PicReal with a size of
8x8(Pixels) to draw real bitmap, and a PictureBox(PicColorBmp)to
draw color bitmap Brush, and two PictureBox to show ForeColor
and BackColor of a bitmap, and a PictureBox to test the color
Brush.
The source code of
program are listed as fllowing.
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 Declare
Function ExtFloodFill Lib "gdi32" (ByVal hdc As Long, ByVal X As
Long, _
ByVal Y As Long,
ByVal crColor As Long, ByVal wFillType 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 GetDC Lib "user32" (ByVal hWnd As Long)
Private Declare
Function CreateBitmap Lib "gdi32" (ByVal nWidth As Long, _
ByVal nHeight As
Long, ByVal nPlanes _
As Long, ByVal
nBitCount As Long, lpBits As Integer) As Long
Private Declare
Function CreatePatternBrush Lib "gdi32" (ByVal hBitmap As Long)
As Long
Private Const
FLOODFILLSURFACE As Long = 1
Private
gridSpaceColor As Long, nGrid As Integer
Private XYspace As
Single, lcBacColor As Long, lcForeColor As Long
Private IsDraw As
Boolean
Private BmpdataStrs()
As String
Private colorBrush
As Long, lcIndex As Integer, isRandColor As Boolean
Private Sub
CmdbmpFromStr_Click()
Dim i As Integer, j
As Single
Dim stArray() As
String
ReDim stArray(0 To
nGrid - 1)
ReDim BmpdataStrs(0
To nGrid - 1)
Erase stArray,
BmpdataStrs
Call
StrConverToBmp(lcIndex)
PicReal.Picture =
Nothing
picContainer.Picture
= Nothing
PicDraw.Picture =
Nothing
For j = 0 To nGrid -
1
'MsgBox
("BmpdataStrs(j)=" & BmpdataStrs(j))
stArray =
Split(BmpdataStrs(j), ",", -1, vbTextCompare)
For i = 0 To
nGrid - 1
If
CLng(Val(stArray(i))) = 0 Then
PicReal.PSet
(i, j), vbBlack
Else
PicReal.PSet
(i, j), vbWhite
End If
Next i
Next j
PicRealMappingTo
picContainer, nGrid
picContainer.Refresh
End Sub
Private Sub
CmdColorBrush_Click()
On Error GoTo
errhander
PicDraw.Picture =
Nothing
CreateColorBrush
PicReal, PicColorBmp, nGrid, lcBacColor, lcForeColor
Dim
newBrush As Long, OldBrush As Long
PicDraw.Circle (120, 120), 100
PicDraw.Line (50, 40)-(330, 390), vbRed
PicColorBmp.Picture = PicColorBmp.Image
newBrush = CreatePatternBrush(PicColorBmp.Picture)
OldBrush = SelectObject(PicDraw.hdc, newBrush)
ExtFloodFill PicDraw.hdc, 130, 130, PicDraw.Point(130, 130),
FLOODFILLSURFACE
SelectObject PicDraw.hdc, OldBrush
DeleteObject newBrush
PicDraw.Refresh
Exit Sub
errhander:
End Sub
Private Sub
CmdSelBackColor_Click()
CommonDialog1.CancelError = True
On Error GoTo
DoNothing
CommonDialog1.ShowColor
lcBacColor =
CommonDialog1.Color
PicBackColor.BackColor = CommonDialog1.Color
Exit Sub
DoNothing:
End Sub
Private Sub
CmdSelFrcolor_Click()
CommonDialog1.CancelError = True
On Error GoTo
DoNothing
CommonDialog1.ShowColor
lcForeColor =
CommonDialog1.Color
PicForeColor.BackColor = CommonDialog1.Color
Exit Sub
DoNothing:
End Sub
Private Sub
Form_Load()
IsDraw = True
Dim i As Integer, j
As Integer
nGrid = 8
ReDim BmpBites(1 To
nGrid, 1 To nGrid)
picContainer.ScaleMode = vbPixels
picContainer.AutoSize = True
XYspace = 40
picContainer.Height
= nGrid * XYspace + 1
picContainer.Width =
nGrid * XYspace + 1
picContainer.AutoSize = True
lcBacColor = vbWhite
lcForeColor =
vbBlack
picContainer.BackColor = lcBacColor
picContainer.ForeColor = lcForeColor
PicReal.ScaleMode =
3
PicReal.ScaleWidth =
nGrid
PicReal.ScaleHeight
= nGrid
PicReal.AutoSize =
True
PicReal.BackColor =
lcBacColor
PicReal.BackColor =
lcBacColor
PicReal.Picture =
PicReal.Image
PicColorBmp.ScaleWidth = nGrid
PicColorBmp.ScaleHeight = nGrid
PicColorBmp.AutoSize
= True
PicColorBmp.BackColor = lcBacColor
PicColorBmp.Picture
= PicColorBmp.Image
picContainer.Cls
picContainer.Picture
= picContainer.Image
gridSpaceColor =
picContainer.Point(5, 5)
PicDraw.Cls
PicDraw.Picture =
Nothing
PicDraw.AutoRedraw =
True
PicDraw.ScaleMode =
3
List1.Clear
List1.AddItem "0:
Horizontal Line"
List1.AddItem "1:
Vertical Line"
List1.AddItem "2:
Cross"
List1.AddItem "3:
BackWard Diagon."
List1.AddItem "4:
ForeWard Diagon."
List1.AddItem "5:
Cross Diagon."
List1.AddItem "6:
short Cross Diagon."
List1.AddItem "7:
Ellipse"
List1.AddItem "8:
Sparyer paint"
isRandColor =
False
End Sub
Private Sub
StrConverToBmp(Index As Integer)
Erase BmpdataStrs
ReDim BmpdataStrs(0
To 7)
Select Case Index
Case 0
BmpdataStrs(0)
= "1,1,1,1,1,1,1,1"
BmpdataStrs(1)
= "1,1,1,1,1,1,1,1"
BmpdataStrs(2)
= "1,1,1,1,1,1,1,1"
BmpdataStrs(3)
= "0,0,0,0,0,0,0,0"
BmpdataStrs(4)
= "0,0,0,0,0,0,0,0"
BmpdataStrs(5)
= "1,1,1,1,1,1,1,1"
BmpdataStrs(6)
= "1,1,1,1,1,1,1,1"
BmpdataStrs(7)
= "1,1,1,1,1,1,1,1"
Case 1
BmpdataStrs(0)
= "1,1,1,0,0,1,1,1"
BmpdataStrs(1)
= "1,1,1,0,0,1,1,1"
BmpdataStrs(2)
= "1,1,1,0,0,1,1,1"
BmpdataStrs(3)
= "1,1,1,0,0,1,1,1"
BmpdataStrs(4)
= "1,1,1,0,0,1,1,1"
BmpdataStrs(5)
= "1,1,1,0,0,1,1,1"
BmpdataStrs(6)
= "1,1,1,0,0,1,1,1"
BmpdataStrs(7)
= "1,1,1,0,0,1,1,1"
Case 2
BmpdataStrs(0)
= "1,1,1,0,0,1,1,1"
BmpdataStrs(1)
= "1,1,1,0,0,1,1,1"
BmpdataStrs(2)
= "1,1,1,0,0,1,1,1"
BmpdataStrs(3)
= "0,0,0,0,0,0,0,0"
BmpdataStrs(4)
= "0,0,0,0,0,0,0,0"
BmpdataStrs(5)
= "1,1,1,0,0,1,1,1"
BmpdataStrs(6)
= "1,1,1,0,0,1,1,1"
BmpdataStrs(7)
= "1,1,1,0,0,1,1,1"
Case 3
BmpdataStrs(0)
= "0,1,1,1,1,1,1,1"
BmpdataStrs(1)
= "1,0,1,1,1,1,1,1"
BmpdataStrs(2)
= "1,1,0,1,1,1,1,1"
BmpdataStrs(3)
= "1,1,1,0,1,1,1,1"
BmpdataStrs(4)
= "1,1,1,1,0,1,1,1"
BmpdataStrs(5)
= "1,1,1,1,1,0,1,1"
BmpdataStrs(6)
= "1,1,1,1,1,1,0,1"
BmpdataStrs(7)
= "1,1,1,1,1,1,1,0"
Case 4
BmpdataStrs(0)
= "1,1,1,1,1,1,1,0"
BmpdataStrs(1)
= "1,1,1,1,1,1,0,1"
BmpdataStrs(2)
= "1,1,1,1,1,0,1,1"
BmpdataStrs(3)
= "1,1,1,1,0,1,1,1"
BmpdataStrs(4)
= "1,1,1,0,1,1,1,1"
BmpdataStrs(5)
= "1,1,0,1,1,1,1,1"
BmpdataStrs(6)
= "1,0,1,1,1,1,1,1"
BmpdataStrs(7)
= "0,1,1,1,1,1,1,1"
Case 5
BmpdataStrs(0)
= "0,1,1,1,1,1,1,0"
BmpdataStrs(1)
= "1,0,1,1,1,1,0,1"
BmpdataStrs(2)
= "1,1,0,1,1,0,1,1"
BmpdataStrs(3)
= "1,1,1,0,0,1,1,1"
BmpdataStrs(4)
= "1,1,1,0,0,1,1,1"
BmpdataStrs(5)
= "1,1,0,1,1,0,1,1"
BmpdataStrs(6)
= "1,0,1,1,1,1,0,1"
BmpdataStrs(7)
= "0,1,1,1,1,1,1,0"
Case 6
BmpdataStrs(0)
= "1,1,1,1,1,1,1,1"
BmpdataStrs(1)
= "1,1,1,1,1,1,1,1"
BmpdataStrs(2)
= "1,1,0,1,1,0,1,1"
BmpdataStrs(3)
= "1,1,1,0,0,1,1,1"
BmpdataStrs(4)
= "1,1,1,0,0,1,1,1"
BmpdataStrs(5)
= "1,1,0,1,1,0,1,1"
BmpdataStrs(6)
= "1,1,1,1,1,1,1,1"
BmpdataStrs(7)
= "1,1,1,1,1,1,1,1"
Case 7
BmpdataStrs(0)
= "1,1,1,1,1,1,1,1"
BmpdataStrs(1)
= "1,1,1,0,0,1,1,1"
BmpdataStrs(2)
= "1,1,0,1,1,0,1,1"
BmpdataStrs(3)
= "1,0,1,1,1,1,0,1"
BmpdataStrs(4)
= "1,0,1,1,1,1,0,1"
BmpdataStrs(5)
= "1,1,0,1,1,0,1,1"
BmpdataStrs(6)
= "1,1,1,0,0,1,1,1"
BmpdataStrs(7)
= "1,1,1,1,1,1,1,1"
Case 8
BmpdataStrs(0)
= "0,1,1,0,1,1,0,1"
BmpdataStrs(1)
= "1,0,1,1,1,0,1,1"
BmpdataStrs(2)
= "0,1,0,1,1,0,1,0"
BmpdataStrs(3)
= "1,1,1,1,0,1,0,1"
BmpdataStrs(4)
= "1,0,1,0,1,1,1,1"
BmpdataStrs(5)
= "1,1,0,1,1,0,1,1"
BmpdataStrs(6)
= "0,1,1,1,1,1,1,1"
BmpdataStrs(7)
= "1,0,1,1,1,1,0,1"
End Select
End Sub
Private Sub
List1_Click()
lcIndex =
List1.ListIndex
MsgBox ("lcindex=" &
lcIndex)
End Sub
Private Sub
Option1_Click()
If Option1.Value =
True Then isRandColor = True
End Sub
Private Sub
picContainer_MouseMove(Button As Integer, Shift As Integer, X As
Single, Y As Single)
Lblxy.Caption = "x="
& X & " ;y=" & Y
On Error Resume Next
Dim Xm, Ym
'===============
If Button = 2
Then Exit Sub
'==========Show
Mouse Position in grid coord=======
Xm = Int(X /
XYspace) + 1
Ym = Int(Y /
XYspace) + 1
Lblxy.Caption =
"xPixel = " & X & "; yPixel = " & Y & "xm=" & Xm & ";ym=" & Ym
End Sub
Private Sub
picContainer_MouseUp(Button As Integer, Shift As Integer, X As
Single, Y As Single)
Dim i As Integer, j
As Integer, ptColor As Long
Dim Xm As Integer,
Ym As Integer
On Error Resume
Next
'--------------
If IsDraw = False
Then Exit Sub
If Button =
vbLeftButton Then
Xm =
(X \ XYspace) + 1 'grid Corrd.
Ym =
(Y \ XYspace) + 1
picContainer.Line ((Xm - 1) * XYspace - 1, (Ym - 1) * XYspace -
1)- _
(Xm
* XYspace - 1, Ym * XYspace - 1), lcForeColor, BF
Else
IsDraw =
False
PicReal.Picture = Nothing 'initial the picturebox
' mapping
picturebox drawing to real bitmap
picContainerMappingTo PicReal, nGrid
'write
down the bitmap data string
WritebmpDataStr PicReal, nGrid, BmpdataStrs
End If
End Sub
Private Sub
picContainerMappingTo(canvas As PictureBox, NgridIn As Integer)
Dim i As Integer, j
As Integer
Dim ptColor As Long
For j = 1 To NgridIn
For i = 1 To
NgridIn
ptColor =
picContainer.Point((i - 1 + 0.5) * XYspace, (j - 1 + 0.5) *
XYspace)
canvas.PSet ((i
- 1), (j - 1)), ptColor
Next i
Next j
End Sub
Private Sub
PicRealMappingTo(canvas As PictureBox, NgridIn As Integer)
Dim i As Integer, j
As Integer
Dim ptColor As Long
canvas.Picture =
Nothing
canvas.Picture =
LoadPicture(App.Path & "\grid8.bmp")
For j = 0 To NgridIn
+ 1
For i = 0 To
NgridIn + 1
ptColor =
PicReal.Point(i, j)
canvas.Line (i
* XYspace + 1, j * XYspace + 1)-((i + 1) * XYspace - 1, (j + 1)
* XYspace - 1), ptColor, BF
Next i
Next j
'canvas.Picture =
canvas.Image
End Sub
Private Sub
WritebmpDataStr(canvas As PictureBox, NgridIn As Integer,
BmpdataStrs() As String)
Dim i As Integer, j
As Integer
Dim ptColor As Long
ReDim BmpdataStrs(0
To nGrid - 1)
For j = 0 To NgridIn
- 1
ptColor =
canvas.Point(0, j)
If Abs(ptColor
- vbWhite) <= 1 Then
BmpdataStrs(j) = "1"
Else
BmpdataStrs(j) = "0"
End If
For i = 1 To
NgridIn - 1
ptColor =
canvas.Point(i, j)
If Abs(ptColor
- vbWhite) <= 1 Then
BmpdataStrs(j)
= Trim(BmpdataStrs(j) + "," & "1")
Else
BmpdataStrs(j)
= Trim(BmpdataStrs(j) + "," & "0")
End If
Next i
PicPrint.Print
"bmpdataStrs(" & j & ")= " & BmpdataStrs(j)
Next j
End Sub
Private Sub
CreateColorBrush(canvasIn As PictureBox, canvasOut As
PictureBox, NgridIn As Integer, _
lcBacColorIn As
Long, lcForeColorIn As Long)
Dim i As Integer, j
As Integer
Dim ptColor As Long,
setColor As Long
canvasOut.Picture =
Nothing
For j = 0 To NgridIn
- 1
For i = 0 To
NgridIn - 1
ptColor =
canvasIn.Point(i, j)
Select Case
isRandColor
Case False
If
Abs(ptColor - vbWhite) <= 2 Then
canvasOut.PSet (i, j), lcBacColorIn
Else
canvasOut.PSet (i, j), lcForeColorIn
End If
Case True
If
Abs(ptColor - vbWhite) <= 2 Then
canvasOut.PSet
(i, j), lcBacColorIn
Else
canvasOut.PSet (i, j), randColors(CInt(Rnd(i) * 15))
End If
End Select
Next i
Next j
End Sub
Private Function
randColors(Index As Integer) As Long
If Index <= 0 Then
Index = 0
If Index >= 15 Then
Index = 15
randColors =
QBColor(Index)
End Function
|
|
