2018年12月02日

如何在VB 6.0中使用VB NET圖案筆刷

在VB 6.0我們經常會使用圖案筆刷以填充一個閉合區域，VB 6.0只提供6種圖案，32 Api號稱有26種，真正可調用的也是6種，單調又欠缺變化。而VB NET提供56種，可使用的為53種。如能在VB 6.0中使用VB NET圖案筆刷可謂美事一樁？如何在VB 6.0中使用VB NET圖案筆刷？觀念其實很簡單，依照下面幾個步驟，就能做到。

 (1).在VB NET中利用下面之程式碼，將VB NET預設筆刷(大陸翻譯為默認筆刷)畫在圖形方塊中，將其儲存成Bitmap圖檔(bmpPatterns)，作為VB 6.0圖形方塊之背景圖案。

Private Sub hatchPlot(ByVal canvas As PictureBox, ByVal nx As Integer, ByVal ny As Integer)

        canvas.Image = New Bitmap(canvas.ClientSize.Width, canvas.ClientSize.Height, Format32bppArgb)

        Dim gp As Graphics = Graphics.FromImage(canvas.Image)

        gp.Clear(canvas.BackColor)

        Dim iX As Single, jY As Single

        Dim x1p As Single, y1p As Single, x2p As Single, y2p As Single       

        Dim st As String, count As Long

       xspace = (canvas.ClientSize.Width - 1) / nx

        yspace = (canvas.ClientSize.Height - 1) / ny

        count = 0

        For jY = 0 To ny - 1

            For iX = 0 To nx - 1

                x1p = iX * xspace

                y1p = jY * yspace

                x2p = (iX + 1) * xspace

                y2p = (jY + 1) * yspace

                Dim the_brush As New HatchBrush

the_brush= Drawing2D.HatchBrush(HatchstylesInd(count), _

 Color.Black, Color.White)

                gp.FillRectangle(the_brush, x1p, y1p, x2p - x1p, y2p - y1p)

                gp.DrawRectangle(New Pen(Color.Red), x1p, y1p, x2p - x1p, y2p - y1p)

                count = count + 1

            Next iX

        Next jY

        bmp = New Bitmap(canvas.Image)

        canvas.Image = bmp

        gp.Dispose()

    End Sub

   The Picture will look like as following.

畫好後之圖就像下圖所示者。

(2)在VB NET中另外用一個8pixels*8pixels圖形方塊(無框線者)，逐次畫出每一種圖案，並讀出每一個縣像素之顏色，0代表黑色1代表白色(當然也可以0代表白黑色1代表白色)。第1種及最後種之顏色字串，就像下面所示者。

Case 0

bmpDataStr(0) = "0,0,0,0,0,0,0,0" ‘0 for Color.black

bmpDataStr(1) = "1,1,1,1,1,1,1,1" ‘1 for Color.white

bmpDataStr(2) = "1,1,1,1,1,1,1,1"

bmpDataStr(3) = "1,1,1,1,1,1,1,1"

bmpDataStr(4) = "1,1,1,1,1,1,1,1"

bmpDataStr(5) = "1,1,1,1,1,1,1,1"

bmpDataStr(6) = "1,1,1,1,1,1,1,1"

bmpDataStr(7) = "1,1,1,1,1,1,1,1"

Case 55

bmpDataStr(0) = "1,1,1,0,1,1,1,1"

bmpDataStr(1) = "1,1,0,0,0,1,1,1"

bmpDataStr(2) = "1,0,0,0,0,0,1,1"

bmpDataStr(3) = "0,0,0,0,0,0,0,1"

bmpDataStr(4) = "1,0,0,0,0,0,1,1"

bmpDataStr(5) = "1,1,0,0,0,1,1,1"

bmpDataStr(6) = "1,1,1,0,1,1,1,1"

bmpDataStr(7) = "1,1,1,1,1,1,1,1"

(3). 在VB 6.0中利用圖形方塊(PicHatchs)載入bmpPatterns圖檔　

(4). 在VB 6.0中將VB NET之 bmpPatterns顏色資料複製至Sub PatternDatasVBNet中。

Private Sub PatternDatasVBNet(ByVal PatternIndex As Integer, ByRef bmpDataStr() As String)

  Erase bmpDataStr

  ReDim Preserve bmpDataStr(0 To 7)

  Select Case PatternIndex

Case 0

bmpDataStr(0) = "0,0,0,0,0,0,0,0"

bmpDataStr(1) = "1,1,1,1,1,1,1,1"

bmpDataStr(2) = "1,1,1,1,1,1,1,1"

bmpDataStr(3) = "1,1,1,1,1,1,1,1"

bmpDataStr(4) = "1,1,1,1,1,1,1,1"

bmpDataStr(5) = "1,1,1,1,1,1,1,1"

bmpDataStr(6) = "1,1,1,1,1,1,1,1"

bmpDataStr(7) = "1,1,1,1,1,1,1,1"

bmpDataStr(0) = "0,0,0,0,0,0,0,0"

bmpDataStr(1) = "0,1,1,1,0,1,1,1"

bmpDataStr(2) = "0,1,1,1,0,1,1,1"

bmpDataStr(3) = "0,1,1,1,0,1,1,1"

bmpDataStr(4) = "0,0,0,0,0,0,0,0"

bmpDataStr(5) = "0,1,1,1,0,1,1,1"

bmpDataStr(6) = "0,1,1,1,0,1,1,1"

bmpDataStr(7) = "0,1,1,1,0,1,1,1"

.

.

.

Case 55

bmpDataStr(0) = "1,1,1,0,1,1,1,1"

bmpDataStr(1) = "1,1,0,0,0,1,1,1"

bmpDataStr(2) = "1,0,0,0,0,0,1,1"

bmpDataStr(3) = "0,0,0,0,0,0,0,1"

bmpDataStr(4) = "1,0,0,0,0,0,1,1"

bmpDataStr(5) = "1,1,0,0,0,1,1,1"

bmpDataStr(6) = "1,1,1,0,1,1,1,1"

bmpDataStr(7) = "1,1,1,1,1,1,1,1"

End Select

End Sub

(5) 利用PicHatchs圖形方塊之PicHatchs_MouseDown()讀取VB NET圖案種類代碼.

Private Sub PicHatchs_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

        Dim Xm, Ym

        On Error Resume Next

        If Button = VB LeftButton Then

            Xm = Int(X / lcXspace) ‘lcXspace=width of each style

            Ym = Int(Y / lcYspace) ‘lcyspace=width of each style

            lcVB netPatternInd = Ym * 4 + Xm

           Lblnetxy.Caption = "x= " & X & "; y= " & Y & " ;StyleIndex= " & lcVB netPatternInd

           CmdPlotbyVnetdata_Click

        End If

    End Sub

(6)利用下列程式碼，創建API圖案筆刷。

Private Sub CmdPlotbyVnetdata_Click()

Dim bmpdatastrNet() As String

Dim stArray() As String

Erase bmpdatastrNet

PatternDatasVB Net lcVB netPatternInd, bmpdatastrNet

ReDim Preserve bmpdatastrNet(0 To UBound(bmpdatastrNet))

PicReal.ScaleMode = 3

PicReal.AutoRedraw = True

PicReal.BorderStyle = 1

PicReal.Width = 8

PicReal.Height = 8

PicReal.AutoSize = True

PicReal.Visible = True

Dim j As Integer, i As Integer

For j = 0 To UBound(bmpdatastrNet)

   Erase stArray

   stArray = Split(bmpdatastrNet(j), ",", -1, VB TextCompare)

   ReDim Preserve stArray(0 To UBound(stArray))

For i = 0 To UBound(bmpdatastrNet)

    If Val(stArray(i)) = 1 Then

        PicReal.PSet (i, j), VB White

    Else

       PicReal.PSet (i, j), VB Blue

    End If

Next i

Next j

PicReal.Picture = PicReal.Image

PicReal.Refresh

 On Error GoTo errhander

              PicDraw.Cls

              PicDraw.Picture = Nothing

              PicDraw.AutoRedraw = True

              Dim newBrush As Long, OldBrush As Long

              PicDraw.DrawStyle = 0

              PicDraw.FillStyle = 1

              PicDraw.Circle (40, 40), 35

               newBrush = CreatePatternBrush(PicReal.Picture)   'image for forecolor ,picture for origin picture

               OldBrush = SelectObject(PicDraw.hdc, newBrush)

               ExtFloodFill PicDraw.hdc, 32, 32, PicDraw.Point(32, 32), FLOODFILLSURFACE 'PicDraw.Point(70, 70) is backcolor

               SelectObject PicDraw.hdc, OldBrush

               DeleteObject newBrush

            PicDraw.Refresh

            Exit Sub

errhander:

    MsgBox ("err in sub CmdPlotbyVnetdata_Click ")

    Exit Sub

End Sub