Tube plot in VB

Tube plot in VB 6.0/ VB NET

Tube Plot

Parametric curves in three space can be difficult to Visualize and draw without the help of graphing package, for a 3D curve like

x=4cos(t),y=4sin(t),z=t   (0<=t<=3pi)

It’s graph shown as following is drawn by computer,

 

    

 

It is still difficult to tell the intersection from which one is in front of the other. To solve the visualization problem, we can draw this kind of curve by drawing the curve enclosing with a thin tube as shown following. Such graphs are called tube plot.

tubeDrawing_2 

tubeDrawing_3

A tube plot is a special case of so called extruded surface. A shape extrusion is the process of forcing a shape displacement along a specific path like the figure shown as following. The basic shape(red) displace along a path(black) get the surface(blue),if the path is a smooth 3d line and the basic shape is a circle then the extruded surface is a 3d tube surface.

Tube Drawing

  The concept of tube drawing is quite simple and easy. The process of tube drawing can be summarized as following:

(1)To divide path line as some line segments,ptspath(0)~ptspath(n+1).

(2)At point ptspath(0), we find a point on the circle(radius is given) as a start point, ptStart.

(3) Rotate the ptStart about line segment ptspath(0)_ptspath(1) m times ,each time using (360/n) degree,we get the basic circle at stage 0, points(0,0)~points(0,m).

(4) Move ptStart to next Stage, call ptStart_1, then rotate the ptStart_1 about line segment ptspath(1)_ptspath(2) m times getting points(1,0)~points(1,m).

.

.

(5) Move ptStart to n Stage, call ptStart_n, then rotate the ptStart_n about line segment ptspath(n-1)_ptspath(n) m times getting points(n,0)~points(n,m).

(6) Tranform the 3d points(i,j).Coord(0~3) to 2d projector point points(i,j).Trans(0~3)

(7) Draw tube surface.

The key snippet codes in Vb(VB Net) are listed as following:

Part A:

Type ptXyz    ‘Structure ptXyz  for VB Net

   X As Single

   Y As Single

   Z As Single

End Type     ‘End Structure for VB Net

Type Point3D

    coord(0 To 3) As Single ‘ Original coordinates.

    trans(0 To 3) As Single ‘ Translated coordinates.

    PrjBotm(0 To 1) As Single

    PrjSide(0 To 1) As Single

    PrjBack(0 To 1) As Single

    ptRGBcol  As Long

End Type

Public Type LineXyz

 pts(0 To 1) As ptXyz

End Type

‘V1Domn2=x2; V1Domn1=x1

‘V2Domn2=y2; V1Domn1=y1

‘V3Domn2=z3; V1Domn1=z1

‘NdoXU: No of loop along path line.

‘NdoYV: No of loop along circle shape.

dxU = (V1Domn2 – V1Domn1) / (NdoXU – 1)

            dyV = (V2Domn2 – V2Domn1) / (NdoYV – 1)

            ReDim ptsPath(0 To NdoXU + 1)

            For i = 0 To NdoXU + 1

            Dim uTpt As Double

            uTpt = CDbl(i * dxU)

            ptsPath(i) = newPointXyz(GetX_Y_ZValFromU(glVbScriptA, XEq, uTpt), GetX_Y_ZValFromU(glVbScriptB, YEq, uTpt), GetX_Y_ZValFromU(glVbScriptC, ZEq, uTpt))

            Next i

    Dim AngRot As Single

    Dim ptTpt As ptXyz

    ReDim Points(0 To NdoXU, 0 To NdoYV)

For i = 0 To NdoXU  ‘along path

      Dim mLine As LineXyz, ptStart As ptXyz

      mLine.pts(0) = ptsPath(i)

      mLine.pts(1) = ptsPath(i + 1)

      If i = 0 Then

      ptStart = ClosestPtAtEndLineXyz_DistGiven(mLine, radTube)

      Else

      ptStart.X = ptStart.X + ptsPath(i).X – ptsPath(i – 1).X

      ptStart.Y = ptStart.Y + ptsPath(i).Y – ptsPath(i – 1).Y

      ptStart.Z = ptStart.Z + ptsPath(i).Z – ptsPath(i – 1).Z

      End If

     For j = 0 To NdoYV  ‘along circle

        AngRot = dyV * j * math.Da

      Call m3RotAboutLineGetPtxyzA(mLine.pts(0), mLine.pts(1), ptStart, AngRot, ptTpt)

      Points(i, j).coord(0) = ptTpt.X

      Points(i, j).coord(1) = ptTpt.Y

      Points(i, j).coord(2) = ptTpt.Z

      Points(i, j).coord(3) = 1#

    Next j

Next i

Part B:

 

Public Function ClosestPtAtEndLineXyz_DistGiven(mLineXyz As LineXyz, myDist As Single) As ptXyz

‘given distance to find end point of a line segment

Dim ptAny As ptXyz

ptAny = newPointXyz(10, 10, 10)

Dim ptVFootAny As ptXyz

ptVFootAny = ClosestPtToLineXyz(mLineXyz, ptAny)

Dim ptAtDistGiven As ptXyz

ptAtDistGiven = ptxyzonLineXyz_GivenDist(ptVFootAny, ptAny, myDist)

Dim dx As Single

Dim dy As Single

Dim dz As Single

dx = mLineXyz.pts(0).X – ptVFootAny.X

dy = mLineXyz.pts(0).Y – ptVFootAny.Y

dz = mLineXyz.pts(0).Z – ptVFootAny.Z

ClosestPtAtEndLineXyz_DistGiven.X = ptAtDistGiven.X + dx

ClosestPtAtEndLineXyz_DistGiven.Y = ptAtDistGiven.Y + dy

ClosestPtAtEndLineXyz_DistGiven.Z = ptAtDistGiven.Z + dz

End Function

Public Function ReflectionPointXyz(mLineXyz As LineXyz, ptOutside As ptXyz) As ptXyz

Dim ptRotBeg As ptXyz

Dim ptRotEnd As ptXyz

Dim ptReflect As ptXyz

ptRotBeg = mLineXyz.pts(0)

ptRotEnd = mLineXyz.pts(1)

Call m3RotAboutLineGetPtxyzA(ptRotBeg, ptRotEnd, ptOutside, 180, ptReflect)

ReflectionPointXyz = ptReflect

End Function

Public Sub m3RotAboutLineGetPtxyzA(ptRotBeg As ptXyz, ptRotEnd As ptXyz, ptIn As ptXyz, CitaDeg As Single, ptOut As ptXyz)

   Dim A As Single, B As Single, C As Single, U As Single, V As Single, W As Single, CitaR As Single, L As Single

   Dim Xin As Single, Yin As Single, Zin As Single

   A = ptRotBeg.X’

   B = ptRotBeg.Y

   C = ptRotBeg.Z

   U = ptRotEnd.X – ptRotBeg.X

   V = ptRotEnd.Y – ptRotBeg.Y

   W = ptRotEnd.Z – ptRotBeg.Z

   Xin = ptIn.X

   Yin = ptIn.Y

   Zin = ptIn.Z

   CitaR = CitaDeg * PI / 180#

   L = Sqr(U ^ 2 + V ^ 2 + W ^ 2)

  ptOut.X = (A * (L ^ 2 – U ^ 2) + U * (-B * V – C * W + U * Xin + V * Yin + W * Zin) + ((Xin – A) * (L ^ 2 – U ^ 2) + U * (B * V + C * W – V * Yin – W * Zin)) * Cos(CitaR) _

          + L * (-C * V + B * W – W * Yin + V * Zin) * Sin(CitaR)) / L ^ 2

  ptOut.Y = (B * (L ^ 2 – V ^ 2) + V * (-A * U – C * W + U * Xin + V * Yin + W * Zin) + ((Yin – B) * (L ^ 2 – V ^ 2) + V * (A * U + C * W – U * Xin – W * Zin)) * Cos(CitaR) _

          + L * (C * U – A * W + W * Xin – U * Zin) * Sin(CitaR)) / L ^ 2

  ptOut.Z = (C * (L ^ 2 – W ^ 2) + W * (-A * U – B * V + U * Xin + V * Yin + W * Zin) + ((Zin – C) * (L ^ 2 – W ^ 2) + W * (A * U + B * V – U * Xin – V * Yin)) * Cos(CitaR) _

          + L * (-B * U + A * V – V * Xin + U * Yin) * Sin(CitaR)) / L ^ 2

   End Sub

tubeDrawing_4

  For more information please link http://www.chday169.url.tw

How to solve an implicit function

How to solve an implicit function

Some time you may need to solve an implicit function like x^3+2*x*y^2+x*y^3-x^2*z^2-25=0 in some domain {x,-5~5},{y,-5~5},{z,-5~5},if you don’t have any software package. In this case, you can use the algorithm of finding roots of a polynomial function like a0+a1*x+a2*x^2+a3*x^3+….+an*x^n just to set z=z0,y=y0 to convert the original function to

 x^3+ 2*x*y0^2+x*y0^3-z0^2-25=0

,and then solve the cubic function of one variable. In this article, you will learn how to use VBScript control to let client to input the function in character string, and the computer will detect the order of the polynomial function and the compute coefficients of the polynomial automatically.

The key point to solve an implicit function with some domain by solving polynomial function is to find the coefficients of a polynomial function when you assume z=z0 and y=y0.

Hereafter are a snippet codes to find coefficients of a polynomial.

Private Sub FindPolyCoeffLH(eqStIn As String, yIn As Single, zIn As Single, eqStOut As String, nPoly As Integer, Acoeff_0() As Double, Optional iTest As Boolean = False)

‘***********************************************

‘Please note here function :A(0)x^n+A(1)x^(n-1)+A(2)x^(n-2)+……..+A(n)

‘if 2x^5+3x^4+2x^3+3x^2+4x+5=0 : then A(0)=2,A(1)=3,A(2)=2,A(3)=3,A(4)=4,A(5)=5

‘***************************************************

Dim i As Integer, count As Integer, j As Integer

Dim x As Single, y As Single, z As Integer

Dim ret As Variant

‘———————————————–

Dim st As String

st = eqStIn

ret = FunValue(st, 0, 0, 0)

‘List1.AddItem “a(0)=” & ret

st = LCase(st)

st = Replace(st, “x*”, “x^1*”)

stArray = Split(st, “+”, -1, vbTextCompare)

‘List1.AddItem St

count = 0

For i = 0 To UBound(stArray)

ReDim Preserve Axyz(0 To count)

Axyz(count) = stArray(i)

‘List1.AddItem “i= ” & count & ” ;Axyz(” & count & “)= ” & Axyz(count)

count = count + 1

Next i

‘————————

count = count – 1

nPoly = -999

For i = 0 To count

    For j = 1 To 10

    If InStr(Axyz(i), Trim(“x^” & j)) And j >= nPoly Then

    nPoly = j

    End If

    Next j

Next i

‘List1.AddItem ” order of poly= ” & nPoly

ReDim Preserve Acoeff_0(0 To nPoly)

Acoeff_0(nPoly) = FunValue(eqStIn, 0, yIn, zIn)

For j = 1 To nPoly

    Acoeff_0(nPoly – j) = 0

    For i = 0 To count

   ‘ MsgBox (“x^” & Trim(“x^” & j) & “;axyz= ” & Axyz(i))

    If InStr(Axyz(i), Trim(“x^” & j)) Then

     Acoeff_0(nPoly – j) = Acoeff_0(nPoly – j) + FunValue(Axyz(i), 1, yIn, zIn)

     End If

    Next i

Next j

If iTest Then

For i = 0 To nPoly

List1.AddItem “z= ” & zIn & ” ;y= ” & yIn & ” A(” & i & “)= ” & Acoeff_0(i)

Next

End If

Dim Fxyz As String

Fxyz = Str(Acoeff_0(0))

For i = 1 To nPoly

Fxyz = Fxyz & Trim(“+” & Str(Acoeff_0(i)) & Trim(“*x^” & i))

Next i

If iTest Then List1.AddItem Fxyz

eqStOut = Fxyz

End Sub

The figure shown as below is the result using the snippet code attached hereafter.

Private Sub ImplicitB(EqIn As String)

‘***********************************************

‘Please note here function :A(0)x^n+A(1)x^(n-1)+A(2)x^(n-2)+……..+A(n)

‘if 2x^5+3x^4+2x^3+3x^2+4x+5=0 : then A(0)=2,A(1)=3,A(2)=2,A(3)=3,A(4)=4,A(5)=5

‘***************************************************

EyeR = 10

EyeTheta = pi * 0.2

EyePhi = pi * 0.2

m3PProject glPST, m3Perspective, EyeR, EyePhi, EyeTheta, FocusX, FocusY, FocusZ, 0, 1, 0

FactorMaker glPST

Dim nPoly As Integer, Acoeff_0() As Double, i As Long, nans As Integer, Nroots As Integer

Dim EqOut As String, Roots As PolyRoot, xans As Single, count As Long

Dim xp As Single, yp As Single, ptsIn() As pointApi, ptsOut() As pointApi

Dim ptTpt As cadPoint

Dim rgbR As Byte, rgbG As Byte, rgbB As Byte, yFctUse As Single

Dim y As Single, z As Single, countTL As Integer

Dim stColl As New Collection, stArray() As String

Dim xFun() As Single, yFun() As Single, zFun() As Single

Dim ansReal() As Double, ansImag() As Double

Dim time1 As Double

time1 = Timer

EqIn = LCase(EqIn)

If InStr(EqIn, “^”) = 0 Then

EqIn = Replace(EqIn, “x”, “x^1″)

End If

List1.AddItem EqIn

countTL = 0

yFctUse = -1

Set stColl = Nothing

For z = 5 To -5 Step -0.25

        count = 0

        Erase ptsIn, ptsOut

        List1.AddItem “z= ” & z

        For y = 5 To -5 Step -0.25

                Call FindPolyCoeffLH(EqIn, y, z, EqOut, nPoly, Acoeff_0)

                ReDim Preserve Acoeff_0(0 To nPoly)

                ReDim Preserve ansReal(1 To nPoly)

                ReDim Preserve ansImag(1 To nPoly)

                Call SolpolyN(nPoly, Acoeff_0, 0.0001, 0, 0, ansReal, ansImag)

                For i = 1 To nPoly

                    If Abs(Round(ansImag(i), 5)) <= 0.0001 Then

                       xans = Round(ansReal(i), 5)

                       List1.AddItem “x,y= ” & xans & ” ; ” & y

                       xp = xans * glAx + y * glAy + z * glAz

                       yp = xans * glBx + y * glBy + z * glBz

                       Picture1.FillColor = QBColor(countTL Mod 16)

                       Picture1.FillStyle = vbSolid

                       Picture1.Circle (xp, yp), (0.1 + (z) * 0.0125), vbRed ‘QBColor(count Mod 16)

                       ReDim Preserve ptsIn(0 To count)

                        ptsIn(count).x = Picture2.ScaleWidth \ 2 + CLng(Picture2.ScaleX(xp * 25 – Picture2.ScaleLeft, Picture2.ScaleMode, vbPixels))

                        ptsIn(count).y = Picture2.ScaleHeight \ 2 + CLng(Picture2.ScaleY(yp * 25 * yFctUse – Picture2.ScaleTop, Picture2.ScaleMode, vbPixels))

                        stColl.Add Trim(Round(xans, 3) & “,” & Round(y, 3) & “,” & Round(z, 3))

                      count = count + 1

                    End If

                Next i

        Next y

          count = count – 1

          If count >= 3 Then

          Dim nansHull As Long

          nansHull = MakeConvexHull(Picture2, ptsIn, ptsOut, QBColor(count Mod 16))

          End If

          countTL = countTL + 1

          List2.AddItem “*******z= ” & z & ” ;npt= ” & count

Next z

       SortNum1_Duplicate stColl

       count = 0

       For i = 1 To stColl.count

       stArray = Split(stColl(i), “,”, -1, vbTextCompare)

       ReDim Preserve xFun(0 To count), yFun(0 To count), zFun(0 To count)

        xFun(count) = Val(stArray(0))

        yFun(count) = Val(stArray(1))

        zFun(count) = Val(stArray(2))

        count = count + 1

      Next i

      count = count – 1

    Dim FileNo As Integer, Fname As String

    Fname = “f:\implicitfunction\ImplicitData.dat”

    FileNo = FreeFile

    Open Fname For Output As #FileNo

       For i = 1 To count

       Write #FileNo, xFun(i), yFun(i), zFun(i)

       Next i

      Close #FileNo

    Lbltime.Caption = (Timer – time1) & “sec”

End Sub

Sub SolpolyN(Nc As Integer, A() As Double, Tol As Double, Rzero As Double, Szero As Double, ansReal() As Double, ansImag() As Double)

    Dim i As Integer

    Dim m As Integer, j As Integer, L As Integer, n As Integer, r As Double, S As Double

    Dim Radtrm As Double, b(9) As Double, Rc As Double, Sc As Double

    Dim p(9) As Double, K As Integer, Rcr As Double, Scr As Double, Q(9) As Double, Rcs As Double

    Dim Scs As Double, Denom As Double, Rnum As Double, Snum As Double, Delr As Double, Dels As Double

    Dim NewN As Integer, rad As Double, Fa As Double, Fb As Double, Ftpt As Double

    ‘Please note here function :A(0)x^n+A(1)X^(n-1)+A(2)x^(n-2)+……..+A(n)

    ‘if 2x^5+3x^4+2x^3+3x^2+4x+5=0 : then A(0)=2,A(1)=3,A(2)=2,A(3)=3,A(4)=4,A(5)=5

    ‘MsgBox (“nc=” & Nc)

    On Error Resume Next

    For i = 1 To Nc

    A(i) = A(i) / A(0)

    ‘MsgBox (“A(I)= ” & i & “;” & A(i))

    Next i

    A(0) = 1

    m = 0

    j = 1

‘!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

Do

    r = Rzero    ‘Rzero initial

    S = Szero    ‘Szero initial

    L = 0

    n = Nc – 2 * m

   ‘ MsgBox (“N=” & n)

Select Case n

‘/////////////////////////////////

Case Is < 2

       ansReal(j) = -A(1)         ‘

            Exit Sub ‘GoTo 500

Case Is = 2

‘/////////////////////////////////

    Fa = A(1) * A(1) – 4# * A(2)

Select Case Fa

            Case Is < 0#

            ‘——————————–

              Radtrm = -(A(1) * A(1) – 4# * A(2))

               rad = Sqr(Radtrm)

               ansReal(j) = A(1) / 2#

               ansReal(j + 1) = -A(1) / 2#

              ansImag(j) = rad / 2#

              ansImag(j + 1) = -rad / 2#

               Exit Sub ‘GoTo 500

            Case Is = 0#

            ‘————————————–

             ansReal(j) = A(1) / 2#

               ansReal(j + 1) = -A(1) / 2#

              ansImag(j) = 0#

              ansImag(j + 1) = 0#

            ‘————————

            Case Is > 0#

             rad = Sqr(A(1) * A(1) – 4# * A(2))

               ansReal(j) = (-A(1) + rad) / 2#

               ansReal(j + 1) = (-A(1) – rad) / 2#

              ansImag(j) = 0#

              ansImag(j + 1) = 0#

               Exit Sub

            End Select

‘calculate approx. values of  R & S計算R,S近似值

Case Is > 2

End Select

‘////////////////////////////////////////////////////

 Do

  b(1) = A(1) – r

   b(2) = A(2) – r * b(1) – S

   For K = 3 To n

   b(K) = A(K) – r * b(K – 1) – S * b(K – 2)

   Next K

   Rc = b(n – 1)

   Sc = b(n) + r * b(n – 1)

   p(1) = -1#

   p(2) = r – b(1)

   For K = 3 To n

   p(K) = -b(K – 1) – r * p(K – 1) – S * p(K – 2)

   Next K

   Rcr = p(n – 1)

   Scr = p(n) + r * p(n – 1) + b(n – 1)

   ‘Calculate b(k) 計算 b(k)偏微分

   Q(1) = 0#

   Q(2) = -1#

   For K = 3 To n

   Q(K) = -b(K – 2) – r * Q(K – 1) – S * Q(K – 2)

   Next K

   Rcs = Q(n – 1)

   Scs = Q(n) + r * Q(n – 1)

   ‘ modify Denom, Rnum, Snum計算微分修正程式

   Denom = Rcr * Scs – Rcs * Scr

   Rnum = -Rc * Scs + Sc * Rcs

   Snum = -Rcr * Sc + Scr * Rc

   Delr = Rnum / Denom

   Dels = Snum / Denom

   ‘計算R,S下一階近似值

   r = r + Delr

   S = S + Dels

   ‘測試微分修正程式是否收斂

   If (Abs(Delr) – Tol) <= 0# And (Abs(Dels) – Tol) <= 0# Then Exit Do

   ‘測試迭代次數是否超過預設值

     If L > 100 Then Exit Sub

     L = L + 1

Loop While True

‘計算二次方程式F(M)之一對根值大小

     Ftpt = (r * r – 4# * S)

Select Case Ftpt

Case Is < 0#

     Radtrm = -Ftpt

     rad = Sqr(Radtrm)

     ansReal(j) = -r / 2#

     ansReal(j + 1) = -r / 2#

     ansImag(j) = rad / 2#

     ansImag(j + 1) = -rad / 2#

Case Is = 0#

     ansReal(j) = -r / 2#

     ansReal(j + 1) = -r / 2#

     ansImag(j) = 0#

     ansImag(j + 1) = 0#

Case Is > 0#

   rad = Sqr(Ftpt)

   ansReal(j) = (-r + rad) / 2#

   ansReal(j + 1) = (-r – rad) / 2#

   ansImag(j) = 0#

   ansImag(j + 1) = 0#

End Select

     ‘P(N-2)取代P(N)後繼續求解

    m = m + 1

    j = j + 2

    NewN = Nc – 2 * m

For K = 1 To NewN

   A(K) = b(K)

   Next K

Loop While True

‘!!!!!!!!!!!!!!!!!!!!!!!!

End Sub

Please note here the input string of polynomial function should obey the rule of Vb syntax, especially, the power of x, you must use “x^2” not ‘x*x”, but you can

use y*y or y^2 and z*z*z or z^3 for y power or z power. In this article we just talk about how to solve the implicit function not concern about the render of implicit function. If you want to render the implicit function, you need to use some package. The figure(x^2+y^2+z^2-1.0) shown below is using the software program(

marching cube algorithm) wrote by author.

 for more information,please refer http://chday169.url.tw

A Simplest way to create a UDT Pattern Brush in Visual Basic

A Simplest way to create a UDT Pattern Brush in Visual Basic

   To create a UDT 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 8×8(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 following.

 

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 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

 .

.

.

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 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

for more information please link: www.chday169.url.tw

Fill an irregular area with a pattern brush in VB Net

How to fill an irregular area with a pattern brush in VB Net

The Vb Net graphics class provides many methods for drawing shapes and filling area, The Vb Net currently has no support any method to fill an irregular area with solid brush,hatch brush or pattern brush. If you want to fill an irregular area with some brush, the easiest and fastest way is use Window Api ExtFloodFill function. In this article you will learn

(1)  how to use ExtFloodFill function

(2)  how to convert VB Net Bitmap class to Api int32 bitmap

(3)  how to use VB Net getHdc function

To use ExtFloodFill function, you shoud Declareit first.

[Private/㎝Public] Declare Function ExtFloodFill Lib “gdi32″ Alias “ExtFloodFill” (ByVal hdc As Int32, ByVal x As Int32, ByVal y As Int32, ByVal crColor As Int32, ByVal wFillType As Int32) As Int32 
hdc

A handle of a device context to perform the flood fill on.

x

The x-coordinate of the point to begin the flood fill at.

y

The y-coordinate of the point to begin the flood fill at.

crColor

The RGB value of the color determining the extent of the flood fill operation. Its exact interpretation depends on the flag passed as wFillType .

wFillType

One of the following flags specifying how to determine the boundary of the flood fill operation:

FLOODFILLBORDER

Fill from the beginning point in all directions until a boundary of color crColor is reached. The flood fill will cover over any colors within the region which do not have the color of crColor.

FLOODFILLSURFACE

Fill from the beginning point in all directions as long as the fill-in color crColor is encountered. The boundary of the flood fill is made up of any color which is not identical to crColor.

The ExtFloodFill function is similar to FloodFill except it takes an extra parameter that determines the fill progresses.If wFillType set to Flloodfillborder(0),it fill stop long as when it finds a pixel with same color crColor, If you set wFillType equal to Flloodfillsurface(1),the fill continues until the function finds the pixel have a different  color. Hereafter is the key snippet code of the program.

Private Sub FloodFillAPI(ByRef brushBmp As Bitmap, ByVal canvas_beFill As PictureBox, ByVal mFillType As Int16, ByVal colorFill As Int32, ByVal Pt As Point)

        If m_FillType = 2 Then

            Dim mbmpGetHbitmap As Int32

            Dim mBrush As Int32

            If mFillType = 2 And brushBmp Is Nothing Then Exit Sub

‘convert VB net Bitmap class bitmap to api bitmap

            mbmpGetHbitmap = brushBmp.GetHbitmap           

            If mFillType = 2 Then mBrush = CreatePatternBrush(mbmpGetHbitmap)

            Dim picHdc As Int32 = canvas_beFill.CreateGraphics.GetHdc()

            Dim hmm As Int32 = SelectObject(picHdc, mBrush)

            ExtFloodFill(picHdc, Pt.X, Pt.Y, GetPixel(picHdc, Pt.X, Pt.Y), 1)

            ‘clearing memory

            DeleteDC(picHdc)

            DeleteObject(mBrush)

            DeleteObject(hmm)

            mbmpGetHbitmap = Nothing

            hmm = Nothing

        Else

            Dim mBrush As Int32

            Dim picHdc As Int32

            Dim hmm As Int32

            If mFillType = 0 Then mBrush = CreateSolidBrush(colorFill)

            If mFillType = 1 Then mBrush = CreateHatchBrush(m_HatchStyle, colorFill)

            picHdc = canvas_beFill.CreateGraphics.GetHdc()

            hmm = SelectObject(picHdc, mBrush)

            Dim ret As Int32 = ExtFloodFill(picHdc, Pt.X, Pt.Y, GetPixel(picHdc, Pt.X, Pt.Y), 1)

            DeleteDC(picHdc)

            DeleteObject(mBrush)

            DeleteObject(hmm)

            hmm = Nothing           

        End If

    End Sub

for more information please link: www.chday169.url.tw

VB NET Predefined Hatch Brush and Known colors

  • How to use VB NET Predefined Hatch Brush and Known colors in VB 6.0

  A hatch pattern brush fills a closed area with a simple pattern of lines, dots or other shapes, VB 6.0 support only six hatch styles, and Win 32 Api support 26 hatch styles(actually oly six are useful?). While VB NET offer 56 hatch styles (53 styles are

useful), if we can use VB NETdefault hatch brushes in VB 6.0 , it will be a wonderful thing? Is it possible? The answer is “yes”, and how to do it. The concept is quite easy and simple.

(2).In VB NET using a arrayList to store the list of hatch name.

      hatchCol.Add(“0_Horizontal_0″)

        hatchCol.Add(“1_Horizontal_0″)

        hatchCol.Add(“2_Vertical_1″)

        hatchCol.Add(“3_ForwardDiagonal_2″)

        hatchCol.Add(“4_BackwardDiagonal_3″)

        hatchCol.Add(“5_LargeGrid_4″)

        hatchCol.Add(“6_LargeGrid_4″)

        hatchCol.Add(“7_LargeGrid_4″)

        hatchCol.Add(“8_DiagonalCross_5″)

        hatchCol.Add(“9_Percent05_6″)

        hatchCol.Add(“10_Percent10_7″)

        hatchCol.Add(“11_Percent20_8″)

        hatchCol.Add(“12_Percent25_9″)

        hatchCol.Add(“13_Percent30_10″)

        hatchCol.Add(“14_Percent40_11″)

        hatchCol.Add(“15_Percent50_12″)

        hatchCol.Add(“16_Percent60_13″)

        hatchCol.Add(“17_Percent70_14″)

        hatchCol.Add(“18_Percent75_15″)

        hatchCol.Add(“19_Percent80_16″)

        hatchCol.Add(“20_Percent90_17″)

        hatchCol.Add(“21_LightDownwardDiagonal_18″)

        hatchCol.Add(“22_LightUpwardDiagonal_19″)

        hatchCol.Add(“23_DarkDownwardDiagonal_20″)

        hatchCol.Add(“24_DarkUpwardDiagonal_21″)

        hatchCol.Add(“25_WideDownwardDiagonal_22″)

        hatchCol.Add(“26_WideUpwardDiagonal_23″)

        hatchCol.Add(“27_LightVertical_24″)

        hatchCol.Add(“28_LightHorizontal_25″)

        hatchCol.Add(“29_NarrowVertical_26″)

        hatchCol.Add(“30_NarrowHorizonta_27″)

        hatchCol.Add(“31_DarkVertical_28″)

        hatchCol.Add(“32_DarkHorizontal_29″)

        hatchCol.Add(“33_DashedDownwardDiagonal_30″)

        hatchCol.Add(“34_DashedUpwardDiagonal_31″)

        hatchCol.Add(“35_DashedHorizontal_32″)

        hatchCol.Add(“36_DashedVertical_33″)

        hatchCol.Add(“37_SmallConfetti_34″)

        hatchCol.Add(“38_LargeConfetti_35″)

        hatchCol.Add(“39_ZigZag_36″)

        hatchCol.Add(“40_Wave_37″)

        hatchCol.Add(“41_DiagonalBrick_38″)

        hatchCol.Add(“42_HorizontalBrick_39″)

        hatchCol.Add(“43_Weave_40″)

        hatchCol.Add(“44_Plaid_41″)

        hatchCol.Add(“45_Divot_42″)

        hatchCol.Add(“46_DottedGrid_43″)

        hatchCol.Add(“47_DottedDiamond_44″)

        hatchCol.Add(“48_Shingle_45″)

        hatchCol.Add(“49_Trellis_46″)

        hatchCol.Add(“50_Sphere_47″)

        hatchCol.Add(“51_SmallGrid_48″)

        hatchCol.Add(“52_SmallCheckerBoard_48″)

        hatchCol.Add(“53_LargeCheckerBoard_50″)

        hatchCol.Add(“54_OutlinedDiamond_51″)

        hatchCol.Add(“55_SolidDiamond_52″)

(2). In VB NET using the following snippet code to draw the VB NET default hatch patterns on a PictureBox and save it as a bitmap.

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.

vbnet_deffault hatch brush

 (3). In VB NETwe use a 8pixels*8pixels PictureBox(PicReal,backcolor=

Color.White, foreColor=Color.Black) as a canvas and fill it by each Hatch pattern, and using getPixel() to retrieve the color data. The pattern color data for the first one( 0_Horizontal_0) and last one(55_SolidDiamond_52) are something like:

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”

(4). In VB 6.0 using a PictureBox(PicHatchs) to load the hatch patterns bitmap by Loadpicture() function.

(5).Copy VB NET pattern color data to 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

(6). In PicHatchs_MouseDown we use the code to get the VB NET hatch index.

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

(7). By clicking sub CmdPlotbyVnetdata_Click to show the result.

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

 

 

 

(8).Follow the similar procedure ,you can draw down the known color of Vb Net,

   by using the snippet code. Attched here,and save the picture as a bitmap.

   In VB 6.0 you just load the bitmap into a PictureBox which saved previously in Vb net,and use point() or Api getpixel() to pick the color you want.

Private Sub FrmCollections_Load(ByVal sender As Object, ByVal e As System.EventArgs) Handles Me.Load

        Dim colorNames As New System.Collections.Generic.List(Of String)

        Dim count As Integer = 0

        For Each colorknown As KnownColor In [Enum].GetValues(GetType(KnownColor)) ‘list color from Arraylist’從列舉預設顏色陣列清單中取出顏色物件

            Dim Colorspec As Color = Color.FromKnownColor(colorknown) ‘

            If Not Colorspec.IsSystemColor Then

                colorNames.Add(colorknown.ToString())

                ReDim Preserve colortables(count), colorNameStrs(count)

                colortables(count) = Colorspec

                colorNameStrs(count) = colorknown.ToString

                count += 1

            End If

        Next colorknown

        ‘colorNames.Sort() ‘If need then use this statement to sort the color name

        For Each colorName As String In colorNames

            ListBox1.Items.Add(colorName) ‘write color name to listBox寫出顏色到ListBox1

        Next colorName

    End Sub

    Private Sub ListBox1_SelectedIndexChanged(ByVal sender As System.Object, ByVal e As System.EventArgs) _

    Handles ListBox1.SelectedIndexChanged ‘從ListBox1選取顏色

        Dim st1 As String

        st1 = ListBox1.SelectedItem.ToString

        Dim col1 As Color

        col1 = Color.FromName(LblColor.Text)

        Dim st2 As String = GetHexColor(col1)

        LblColor.Text = st1

        PicColorShow.BackColor = Color.FromName(st1) ‘display color 顯示顏色

    End Sub

    Private Sub DrawKnownColors(ByRef Canvas As PictureBox, ByVal nGridX As Integer, ByVal nGridY As Integer)

        Dim i, j As Integer

        Dim xspace, yspace As Single

        xspace = (Canvas.Width – 1) / nGridX

        yspace = (Canvas.Height – 1) / nGridY

        Canvas.Image = New Bitmap(Canvas.Width, Canvas.Height)

        bmp = Canvas.Image

        Dim gr As Graphics = Graphics.FromImage(bmp)

        Dim count As Integer = 0

        For j = 0 To nGridY – 1

            For i = 0 To nGridX – 1

                Dim x1 As Single = i * xspace

                Dim y1 As Single = j * yspace

                Dim x2 As Single = (i + 1) * xspace

                Dim y2 As Single = (j + 1) * yspace

                gr.FillRectangle(New SolidBrush(colortables(count)), x1, y1, x2, y2)

                gr.DrawRectangle(New Pen(Color.Black), x1, y1, x2, y2)

                count += 1

            Next

        Next

        Canvas.Image = bmp

        gr.Dispose()

    End Sub

    Private Sub ButDrawColors_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles ButDrawColors.Click

        DrawKnownColors(picColorsA, 47, 3)

        DrawKnownColors(PicColorsB, 3, 47)

    End Sub

    Private Sub picColorsA_MouseMove(ByVal sender As Object, ByVal e As System.Windows.Forms.MouseEventArgs) Handles picColorsA.MouseMove

        Dim xspace, yspace As Single

        xspace = (picColorsA.Width – 1) / 47

        yspace = (picColorsA.Height – 1) / 3

        Dim xm, ym As Integer

        xm = e.X \ xspace

        ym = e.Y \ yspace

        Dim indcol As Integer = ym * 47 + xm

        If indcol <= 140 Then LblColIndA.Text = “colorIndex= ” & indcol & “; ” & colorNameStrs(indcol) & ” ;R=” & colortables(indcol).R _

        & ” ;G=” & colortables(indcol).G & “;B=” & colortables(indcol).B

    End Sub

    Private Sub picColorsB_MouseMove(ByVal sender As Object, ByVal e As System.Windows.Forms.MouseEventArgs) Handles PicColorsB.MouseMove

        Dim xspace, yspace As Single

        xspace = (PicColorsB.Width – 1) / 3

        yspace = (PicColorsB.Height – 1) / 47

        Dim xm, ym As Integer

        xm = e.X \ xspace

        ym = e.Y \ yspace

        Dim indcol As Integer = ym * 3 + xm

        If indcol <= 140 Then LblColIndB.Text = “colorIndex= ” & indcol & “; ” & colorNameStrs(indcol) & ” ;R=” & colortables(indcol).R _

        & ” ;G=” & colortables(indcol).G & “;B=” & colortables(indcol).B

    End Sub

for more information please link www.chday169.url.tw