Visual Basic Graphics Programming (2nd Edition)/Visual Basic Graphics Programming 2nd Edition.iso/OldSrc/CH12/SRC/OBJPLIN1.CLS

Text File | 1996-04-02 | 13.7 KB | 517 lines

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "ObjPolyline"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Option Explicit

' Point3D and Segment3D are defined in module M3OPS.BAS as:
'    Type Point3D
'        coord(1 To 4) As Single
'        trans(1 To 4) As Single
'    End Type
'
'    Type Segment3D
'        pt1 As Integer
'        pt2 As Integer
'    End Type

Private NumPoints As Integer ' Number of points.
Private Points() As Point3D  ' Data points.

Private NumSegs As Integer   ' Number of segments.
Private Segs() As Segment3D  ' The segments.

Private IsCulled As Boolean

' ***********************************************
' This is done at drawing time for polylines.
' ***********************************************
Public Sub ClipEye(r As Single)
End Sub

' ************************************************
' Draw the transformed points on a Form, Printer,
' or PictureBox using API functions.
' ************************************************
Public Sub DrawOrdered(canvas As Object, Optional r As Variant)
Dim seg As Integer
Dim pt1 As Integer
Dim pt2 As Integer
Dim dist As Single
Dim status As Long

    ' Don't draw if culled.
    If IsCulled Then Exit Sub

    On Error Resume Next
    If IsMissing(r) Then r = INFINITY
    dist = r
    For seg = 1 To NumSegs
        pt1 = Segs(seg).pt1
        pt2 = Segs(seg).pt2
        ' Don't draw if either point is farther
        ' from the focus point than the center of
        ' projection (which is distance dist away).
        If Points(pt1).trans(3) < dist And _
           Points(pt2).trans(3) < dist Then
                #If Win32 Then
                    status = API_MoveTo(canvas.hdc, _
                        Points(pt1).trans(1), _
                        Points(pt1).trans(2), 0&)
                #Else
                    status = API_MoveTo(canvas.hdc, _
                        Points(pt1).trans(1), _
                        Points(pt1).trans(2))
                #End If
                status = API_LineTo(canvas.hdc, _
                    Points(pt2).trans(1), _
                    Points(pt2).trans(2))
        End If
    Next seg
End Sub

' ***********************************************
' Return the maximum transformed Z value for this
' object.
' ***********************************************
Property Get zmax() As Single
Dim best As Single
Dim z As Single
Dim i As Integer

    best = Points(1).trans(3)
    For i = 2 To NumPoints
        z = Points(i).trans(3)
        If best < z Then best = z
    Next i
    zmax = best
End Property



Sub Stellate(L As Single, ParamArray coord() As Variant)
Dim x0 As Single
Dim y0 As Single
Dim z0 As Single
Dim x1 As Single
Dim y1 As Single
Dim z1 As Single
Dim x2 As Single
Dim y2 As Single
Dim z2 As Single
Dim x3 As Single
Dim y3 As Single
Dim z3 As Single
Dim Ax As Single
Dim Ay As Single
Dim Az As Single
Dim Bx As Single
Dim By As Single
Dim Bz As Single
Dim nx As Single
Dim ny As Single
Dim nz As Single
Dim num As Integer
Dim i As Integer
Dim pt As Integer

    num = (UBound(coord) + 1) \ 3
    If num < 3 Then
        Beep
        MsgBox "Must have at least 3 points to stellate.", , vbExclamation
        Exit Sub
    End If

    ' (x0, y0, z0) is the center of the polygon.
    x0 = 0
    y0 = 0
    z0 = 0
    pt = 0
    For i = 1 To num
        x0 = x0 + coord(pt)
        y0 = y0 + coord(pt + 1)
        z0 = z0 + coord(pt + 2)
        pt = pt + 3
    Next i
    x0 = x0 / num
    y0 = y0 / num
    z0 = z0 / num

    ' Find the normal.
    x1 = coord(0)
    y1 = coord(1)
    z1 = coord(2)
    x2 = coord(3)
    y2 = coord(4)
    z2 = coord(5)
    x3 = coord(6)
    y3 = coord(7)
    z3 = coord(8)
    Ax = x2 - x1
    Ay = y2 - y1
    Az = z2 - z1
    Bx = x3 - x2
    By = y3 - y2
    Bz = z3 - z2
    m3Cross nx, ny, nz, Ax, Ay, Az, Bx, By, Bz

    ' Give the normal length L.
    m3SizeVector L, nx, ny, nz

    ' The normal + <x0, y0, z0> gives the point.
    x0 = x0 + nx
    y0 = y0 + ny
    z0 = z0 + nz

    ' Build the segments that make up the object.
    x1 = coord(3 * num - 3)
    y1 = coord(3 * num - 2)
    z1 = coord(3 * num - 1)
    pt = 0
    For i = 1 To num
        x2 = coord(pt)
        y2 = coord(pt + 1)
        z2 = coord(pt + 2)
        AddSegment x1, y1, z1, x2, y2, z2, x0, y0, z0
        x1 = x2
        y1 = y2
        z1 = z2
        pt = pt + 3
    Next i
End Sub

Sub CreateNormal(Objects As Collection)
Dim pline As New ObjPolyline
Dim x1 As Single
Dim y1 As Single
Dim z1 As Single
Dim x2 As Single
Dim y2 As Single
Dim z2 As Single

    Objects.Add pline
    UnitNormalSegment x1, y1, z1, x2, y2, z2
    pline.AddSegment x1, y1, z1, x2, y2, z2
End Sub


' ***********************************************
' Compute a normal vector for this polyline.
' ***********************************************
Sub NormalVector(nx As Single, ny As Single, nz As Single)
Dim Ax As Single
Dim Ay As Single
Dim Az As Single
Dim Bx As Single
Dim By As Single
Dim Bz As Single

    Ax = Points(2).coord(1) - Points(1).coord(1)
    Ay = Points(2).coord(2) - Points(1).coord(2)
    Az = Points(2).coord(3) - Points(1).coord(3)
    Bx = Points(3).coord(1) - Points(2).coord(1)
    By = Points(3).coord(2) - Points(2).coord(2)
    Bz = Points(3).coord(3) - Points(2).coord(3)
    m3Cross nx, ny, nz, Ax, Ay, Az, Bx, By, Bz
End Sub



' ***********************************************
' Compute the unit normal line segment for this
' polyline.
' ***********************************************
Sub UnitNormalSegment(x1 As Single, y1 As Single, z1 As Single, x2 As Single, y2 As Single, z2 As Single)
Dim i As Integer
Dim nx As Single
Dim ny As Single
Dim nz As Single

    UnitNormalVector nx, ny, nz

    x1 = 0
    y1 = 0
    z1 = 0
    For i = 1 To NumPoints
        x1 = x1 + Points(i).coord(1)
        y1 = y1 + Points(i).coord(2)
        z1 = z1 + Points(i).coord(3)
    Next i
    x1 = x1 / NumPoints
    y1 = y1 / NumPoints
    z1 = z1 / NumPoints

    x2 = x1 + nx
    y2 = y1 + ny
    z2 = z1 + nz
End Sub


' ***********************************************
' Compute the unit normal vector for this
' polyline.
' ***********************************************
Sub UnitNormalVector(nx As Single, ny As Single, nz As Single)
Dim D As Single

    NormalVector nx, ny, nz
    D = Sqr(nx * nx + ny * ny + nz * nz)
    nx = nx / D
    ny = ny / D
    nz = nz / D
End Sub





Property Let Culled(value As Boolean)
    IsCulled = value
End Property


' ***********************************************
' Return a string indicating the object type.
' ***********************************************
Property Get ObjectType() As String
    ObjectType = "POLYLINE"
End Property

' ************************************************
' Add one or more line segments to the polyline.
' ************************************************
Public Sub AddSegment(ParamArray coord() As Variant)
Dim num_segs As Integer
Dim i As Integer
Dim last As Integer
Dim pt As Integer

    num_segs = (UBound(coord) + 1) \ 3 - 1
    ReDim Preserve Segs(1 To NumSegs + num_segs)

    last = AddPoint((coord(0)), (coord(1)), (coord(2)))
    pt = 0
    For i = 1 To num_segs
        Segs(NumSegs + i).pt1 = last
        pt = pt + 3
        last = AddPoint((coord(pt)), (coord(pt + 1)), (coord(pt + 2)))
        Segs(NumSegs + i).pt2 = last
    Next i

    NumSegs = NumSegs + num_segs
End Sub

' ************************************************
' Add a point to the polyline. Return the point's
' index.
' ************************************************
Private Function AddPoint(x As Single, y As Single, z As Single) As Integer
Dim i As Integer

    ' See if the point is already here.
    For i = 1 To NumPoints
        If x = Points(i).coord(1) And _
           y = Points(i).coord(2) And _
           z = Points(i).coord(3) Then _
                Exit For
    Next i
    AddPoint = i

    ' If so, we're done.
    If i <= NumPoints Then Exit Function

    ' Otherwise create the new point.
    NumPoints = NumPoints + 1
    ReDim Preserve Points(1 To NumPoints)
    Points(i).coord(1) = x
    Points(i).coord(2) = y
    Points(i).coord(3) = z
    Points(i).coord(4) = 1#
End Function


' ************************************************
' Draw the object into a metafile.
' ************************************************
Public Sub MakeWMF(mhdc As Integer, Optional r As Variant)
Dim status As Integer
Dim seg As Integer
Dim pt1 As Integer
Dim pt2 As Integer
Dim dist As Single

    On Error Resume Next
    If IsMissing(r) Then r = INFINITY
    dist = r
    For seg = 1 To NumSegs
        pt1 = Segs(seg).pt1
        pt2 = Segs(seg).pt2
        ' Don't draw if either point is farther
        ' from the focus point than the center of
        ' projection (which is distance dist away).
        If Points(pt1).trans(3) < r And Points(pt2).trans(3) < r Then
            #If Win32 Then
                status = API_MoveTo(mhdc, Points(pt1).trans(1), Points(pt1).trans(2), 0&)
            #Else
                status = API_MoveTo(mhdc, Points(pt1).trans(1), Points(pt1).trans(2))
            #End If
            status = API_LineTo(mhdc, Points(pt2).trans(1), Points(pt2).trans(2))
        End If
    Next seg
End Sub


' ***********************************************
' Fix the data coordinates at their transformed
' values.
' ***********************************************
Public Sub FixPoints()
Dim i As Integer
Dim j As Integer

    For i = 1 To NumPoints
        For j = 1 To 3
            Points(i).coord(j) = Points(i).trans(j)
        Next j
    Next i
End Sub

' ************************************************
' Apply a transformation matrix which may not
' contain 0, 0, 0, 1 in the last column to the
' object.
' ************************************************
Public Sub ApplyFull(M() As Single)
Dim i As Integer

    If IsCulled Then Exit Sub
    For i = 1 To NumPoints
        m3ApplyFull Points(i).coord, M, Points(i).trans
    Next i
End Sub

' ************************************************
' Apply a transformation matrix to the object.
' ************************************************
Public Sub Apply(M() As Single)
Dim i As Integer

    If IsCulled Then Exit Sub
    For i = 1 To NumPoints
        m3Apply Points(i).coord, M, Points(i).trans
    Next i
End Sub


' ************************************************
' Apply a nonlinear transformation.
' ************************************************
Public Sub Distort(D As Object)
Dim i As Integer

    For i = 1 To NumPoints
        D.Distort Points(i).coord(1), Points(i).coord(2), Points(i).coord(3)
    Next i
End Sub

' ************************************************
' Write a polyline to a file using Write.
' Begin with "POLYLINE" to identify this object.
' ************************************************
Public Sub FileWrite(filenum As Integer)
Dim i As Integer

    Write #filenum, "POLYLINE", NumPoints, NumSegs

    ' Write the points.
    For i = 1 To NumPoints
        Write #filenum, Points(i).coord(1), Points(i).coord(2), Points(i).coord(3)
    Next i

    ' Write the segments.
    For i = 1 To NumSegs
        Write #filenum, Segs(i).pt1, Segs(i).pt2
    Next i
End Sub

' ************************************************
' Draw the transformed points on a Form, Printer,
' or PictureBox.
' ************************************************
Public Sub Draw(canvas As Object, Optional r As Variant)
Dim seg As Integer
Dim pt1 As Integer
Dim pt2 As Integer
Dim dist As Single

    ' Don't draw if culled.
    If IsCulled Then Exit Sub

    On Error Resume Next
    If IsMissing(r) Then r = INFINITY
    dist = r
    For seg = 1 To NumSegs
        pt1 = Segs(seg).pt1
        pt2 = Segs(seg).pt2
        ' Don't draw if either point is farther
        ' from the focus point than the center of
        ' projection (which is distance dist away).
        If Points(pt1).trans(3) < dist And _
           Points(pt2).trans(3) < dist Then _
                canvas.Line _
                    (Points(pt1).trans(1), Points(pt1).trans(2))- _
                    (Points(pt2).trans(1), Points(pt2).trans(2))
    Next seg
End Sub
' ***********************************************
' Perform backface removal.
' ***********************************************
Public Sub Cull(x As Single, y As Single, z As Single)
Dim Ax As Single
Dim Ay As Single
Dim Az As Single
Dim nx As Single
Dim ny As Single
Dim nz As Single

    ' Compute a normal to the face.
    NormalVector nx, ny, nz

    ' Compute a vector from the center of
    ' projection to the face.
    Ax = Points(1).coord(1) - x
    Ay = Points(1).coord(2) - y
    Az = Points(1).coord(3) - z

    ' See if the vectors meet at an angle < 90.
    IsCulled = (Ax * nx + Ay * ny + Az * nz >= 0)
End Sub
' ************************************************
' Read a polyline from a file using Input.
' Assume the "POLYLINE" label has already been
' read.
' ************************************************
Public Sub FileInput(filenum As Integer)
Dim i As Integer

    Input #filenum, NumPoints, NumSegs

    ' Allocate and read the points.
    ReDim Points(1 To NumPoints)
    For i = 1 To NumPoints
        Input #filenum, Points(i).coord(1), Points(i).coord(2), Points(i).coord(3)
        Points(i).coord(4) = 1
    Next i

    ' Allocate and read the segments.
    ReDim Segs(1 To NumSegs)
    For i = 1 To NumSegs
        Input #filenum, Segs(i).pt1, Segs(i).pt2
    Next i
End Sub