home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Graphics Programming (2nd Edition) / Visual Basic Graphics Programming 2nd Edition.iso / Src / Ch14 / Seg3d.bas < prev    next >
Encoding:
BASIC Source File  |  1999-06-20  |  4.2 KB  |  141 lines
  1. Attribute VB_Name = "Seg3D"
  2. Option Explicit
  3.  
  4. Public Type Segment
  5.     ' The points to connect.
  6.     fr_pt(1 To 4) As Single
  7.     to_pt(1 To 4) As Single
  8.     
  9.     ' The transformed points to connect.
  10.     fr_tr(1 To 4) As Single
  11.     to_tr(1 To 4) As Single
  12. End Type
  13.  
  14. Public Type Transformation
  15.     M(1 To 4, 1 To 4) As Single
  16. End Type
  17.  
  18. Public NumSegments As Integer
  19. Public Segments() As Segment
  20. ' Check that all of the segments in this object
  21. ' have the same length. Return true if the
  22. ' segments all have the same length.
  23. Public Function SameSideLengths(ByVal pt1 As Integer, ByVal pt2 As Integer) As Boolean
  24. Dim A As Single
  25. Dim B As Single
  26. Dim C As Single
  27. Dim S As Single
  28. Dim i As Integer
  29.  
  30.     A = Segments(pt1).fr_pt(1) - Segments(pt1).to_pt(1)
  31.     B = Segments(pt1).fr_pt(2) - Segments(pt1).to_pt(2)
  32.     C = Segments(pt1).fr_pt(3) - Segments(pt1).to_pt(3)
  33.     S = Sqr(A * A + B * B + C * C)
  34.     
  35.     SameSideLengths = False
  36.     For i = pt1 + 1 To pt2
  37.         A = Segments(i).fr_pt(1) - Segments(i).to_pt(1)
  38.         B = Segments(i).fr_pt(2) - Segments(i).to_pt(2)
  39.         C = Segments(i).fr_pt(3) - Segments(i).to_pt(3)
  40.         If Abs(S - Sqr(A * A + B * B + C * C)) > 0.001 Then Exit Function
  41.     Next i
  42.     
  43.     SameSideLengths = True
  44. End Function
  45.  
  46. ' Apply the translation matrix to all the
  47. ' segments using m3ApplyFull. The transformation
  48. ' may not have 0, 0, 0, 1 in its last column.
  49. Public Sub TransformAllDataFull(M() As Single)
  50.     TransformDataFull M, 1, NumSegments
  51. End Sub
  52.  
  53. ' Apply the translation matrix to the indicated
  54. ' segments using m3ApplyFull. The transformation
  55. ' may not have 0, 0, 0, 1 in its last column.
  56. Public Sub TransformDataFull(M() As Single, ByVal seg1 As Integer, ByVal seg2 As Integer)
  57. Dim i As Integer
  58.     
  59.     For i = seg1 To seg2
  60.         m3ApplyFull Segments(i).fr_pt, M, Segments(i).fr_tr
  61.         m3ApplyFull Segments(i).to_pt, M, Segments(i).to_tr
  62.     Next i
  63. End Sub
  64.  
  65.  
  66. ' Apply the translation matrix to all of the
  67. ' segments using m3Apply. This transformation
  68. ' must have 0, 0, 0, 1 in its last column.
  69. Public Sub TransformAllData(M() As Single)
  70.     TransformData M, 1, NumSegments
  71. End Sub
  72.  
  73.  
  74.  
  75.  
  76. ' Apply the translation matrix to all the
  77. ' indicated segments using m3Apply. This
  78. ' transformation must have 0, 0, 0, 1 in its last
  79. ' column.
  80. Public Sub TransformData(M() As Single, ByVal seg1 As Integer, ByVal seg2 As Integer)
  81. Dim i As Integer
  82.     
  83.     For i = seg1 To seg2
  84.         m3Apply Segments(i).fr_pt, M, Segments(i).fr_tr
  85.         m3Apply Segments(i).to_pt, M, Segments(i).to_tr
  86.     Next i
  87. End Sub
  88.  
  89. ' Set the point data to the transformed point data.
  90. Public Sub SetPoints(ByVal seg1 As Integer, ByVal seg2 As Integer)
  91. Dim i As Integer
  92. Dim j As Integer
  93.  
  94.     For i = seg1 To seg2
  95.         For j = 1 To 3
  96.             Segments(i).fr_pt(j) = Segments(i).fr_tr(j)
  97.             Segments(i).to_pt(j) = Segments(i).to_tr(j)
  98.         Next j
  99.     Next i
  100. End Sub
  101.  
  102. ' Draw the transformed segments.
  103. Public Sub DrawAllData(ByVal pic As Object, ByVal color As Long, ByVal clear As Boolean)
  104.     DrawSomeData pic, 1, NumSegments, color, clear
  105. End Sub
  106.  
  107. ' Draw the indicated transformed segments.
  108. Public Sub DrawSomeData(ByVal pic As Object, ByVal first_seg As Integer, ByVal last_seg As Integer, ByVal color As Long, ByVal clear As Boolean)
  109. Dim i As Integer
  110. Dim x1 As Single
  111. Dim y1 As Single
  112. Dim x2 As Single
  113. Dim y2 As Single
  114.  
  115.     If clear Then pic.Cls
  116.     
  117.     pic.ForeColor = color
  118.     For i = first_seg To last_seg
  119.         x1 = Segments(i).fr_tr(1)
  120.         y1 = Segments(i).fr_tr(2)
  121.         x2 = Segments(i).to_tr(1)
  122.         y2 = Segments(i).to_tr(2)
  123.         pic.Line (x1, y1)-(x2, y2)
  124.     Next i
  125. End Sub
  126.  
  127.  
  128. ' Create a segment.
  129. Public Sub MakeSegment(ByVal x1 As Single, ByVal y1 As Single, ByVal z1 As Single, ByVal x2 As Single, ByVal y2 As Single, ByVal z2 As Single)
  130.     NumSegments = NumSegments + 1
  131.     ReDim Preserve Segments(1 To NumSegments)
  132.     Segments(NumSegments).fr_pt(1) = x1
  133.     Segments(NumSegments).fr_pt(2) = y1
  134.     Segments(NumSegments).fr_pt(3) = z1
  135.     Segments(NumSegments).fr_pt(4) = 1
  136.     Segments(NumSegments).to_pt(1) = x2
  137.     Segments(NumSegments).to_pt(2) = y2
  138.     Segments(NumSegments).to_pt(3) = z2
  139.     Segments(NumSegments).to_pt(4) = 1
  140. End Sub
  141.