home *** CD-ROM | disk | FTP | other *** search
/ The Houseplan Collection / HRCD2005.ISO / data1.cab / Zusatz / 3DS / DATA2.Z / Torus.bas < prev    next >
BASIC Source File  |  1999-01-27  |  12KB  |  379 lines
  1. Attribute VB_Name = "Torus"
  2. ' MS Visual Basic Demo-Programm zur Demonstration der ActiveX-FΣhigkeit
  3. ' von ArCon(+).
  4. '
  5. ' Der abgebildete Code dient lediglich Demonstrationszwecken.
  6. ' Es wird keinerlei Garantie fⁿr die Richtigkeit und/oder
  7. ' FunktionsfΣhigkeit ⁿbernommen. Bei Fragen wenden Sie sich bitte an
  8. '
  9. '    mb-Programme
  10. '    Software im Bauwesen GmbH
  11. '    Hermannstra▀e 1
  12. '    D-31785 Hameln
  13. '    e-mail:  arcon@mb-hameln.de
  14. '    Internet http://www.mb-hameln.de
  15.  
  16. Option Explicit
  17.  
  18. #Const HasHoles = 0     ' Erzeuge Polygone ohne L÷chern
  19.  
  20. Declare Function GetTickCount Lib "Kernel32" () As Long
  21.  
  22. Private Const pi As Single = 3.1415926
  23. Private Const twoPi As Single = pi * 2
  24.     
  25. Private Const facX As Integer = 30
  26. Private Const facY As Integer = 16
  27. Private Const rRat As Single = 0.8
  28. Private Const FAK As Single = 0.2
  29. Private Const FAK2 As Single = 0.3
  30.  
  31. Private Const theTexture As String = ">wand\tapete\kinder\kaefer1.bmp"
  32.  
  33. Private constr As ArCon.ObjectConstructor
  34. Private mat As ArCon.Material, Instance As ArCon.Object3D
  35. Private aniList As ArCon.ObjectTransformerCollection
  36.  
  37. Private Type Punkt
  38.     x As Single
  39.     y As Single
  40.     z As Single
  41.     u As Single
  42.     v As Single
  43. End Type
  44.  
  45. Private ps(facY, facX) As Punkt
  46.  
  47. Public Sub StopTest()
  48.     Set aniList = Nothing
  49. End Sub
  50.  
  51. Public Sub DoTest()
  52.     Set constr = Main.ArConEXE.NewObjectConstructor(0, twoPi / 360 * 105)
  53.     Set mat = Main.ArConEXE.NewMaterial
  54.     mat.AmbientCoefficient = 0.2
  55.     mat.DiffuseCoefficient = 0.4
  56.     mat.SpecularCoefficient = 0.4
  57.     mat.DiffuseColor = RGB(255, 255, 255)
  58.     mat.SpecularColor = RGB(255, 255, 255)
  59.     mat.Transparent = False
  60. #If HasHoles Then
  61.     mat.Flags = ACMATFL_ISTEXTURED + ACMATFL_TWOSIDED
  62. #Else
  63.     mat.Flags = ACMATFL_ISTEXTURED
  64. #End If
  65.  
  66.     Dim t1 As Long, t2 As Long
  67.     Main.ArConEXE.StartProgressbar "Erzeuge einen Torus", 0
  68.     t1 = GetTickCount()
  69.     GenTorus
  70.     t2 = GetTickCount
  71.     Main.ArConEXE.SetProgressbarSubTitle "Nachbarschaften & Normalen berechnen"
  72.     constr.Finish "Der Torus", False, ACO_DURATION_CACHEABLE
  73.     Main.ArConEXE.StopProgressbar
  74.     Main.ArConEXE.SetStatusText CStr(t2 - t1) & " ms"
  75.     
  76.     Dim m2w(3, 3) As Single
  77.     Dim l As ArCon.Label
  78.     Dim i As Integer, j As Integer
  79.     For i = 0 To 3
  80.         For j = 0 To 3
  81.             m2w(i, j) = 0
  82.         Next
  83.     Next
  84.     m2w(0, 0) = 5
  85.     m2w(1, 1) = 5
  86.     m2w(2, 2) = 0.5
  87.     m2w(3, 3) = 1
  88.     
  89.     Set Instance = constr.Create(Nothing, False)
  90.     If Instance Is Nothing Then
  91.         MsgBox "Konstruktion des Torus ist fehlgeschlagen"
  92.         End
  93.     End If
  94.     Instance.Flags = AC_3DFL_DBLCLICK Or AC_3DFL_CONSTMODE Or AC_3DFL_DESIGNMODE Or AC_3DFL_SHOWALL
  95.     Instance.SetModelToWorldTransformation m2w
  96.     
  97.     ' Ein 3D-Objekt mit 2D Ersatzdarstellung darf nicht (zusΣtzlich)
  98.     ' in die Welt eingefⁿgt werden, da es bereits ⁿber das zugeorndete
  99.     ' 2D-Objekt verwaltet wird.
  100.     ' Ansonsten wⁿrde hier folgen:
  101.     ' Instance.InsertIntoWorld False
  102.     
  103.     Set l = Main.ArConEXE.NewLabel(AC_LayerLast)
  104.     l.Caption = "Ein Torus"
  105.     With l.Font
  106.         .Name = "Arial"
  107.         .Size = 12
  108.         .Bold = True
  109.         .Italic = True
  110.     End With
  111.     l.Left = 1
  112.     l.Top = 2
  113.     l.Width = 2
  114.     l.Height = 0.5
  115.     l.Angle = 0.3
  116.     l.Visible = True
  117.     l.Selectable = True
  118.     Main.ArConEXE.CurrentStory.Graphics2D.Add l
  119.     Instance.SetOutline2D l, LoadResPicture(1, vbResCursor), "ACHTUNG: hier nicht klicken!"
  120.     Main.ArConEXE.Redraw3DViews
  121.         
  122.     ' Set aniList = Main.ArConEXE.NewObjectTransformerCollection
  123.     ' aniList.Add Instance, m2w
  124.  
  125.     ' Set mat = Nothing
  126.     
  127.     ' Der ObjectConstructor darf erst freigegeben werden, wenn es keine daraus
  128.     ' konstruierten Objekte mehr gibt. Daher ist folgendes falsch:
  129.     ' Set constr = Nothing
  130. End Sub
  131.  
  132. Public Sub DoStep()
  133.     Static initDone As Boolean
  134.     Static m2w(3, 3) As Single
  135.     Static stepNo As Integer
  136.     
  137.     If Not initDone Then
  138.         Dim i As Integer, j As Integer
  139.         initDone = True
  140.         stepNo = 0
  141.         For i = 0 To 3
  142.             For j = 0 To 3
  143.                 m2w(i, j) = 0
  144.             Next
  145.         Next
  146.         m2w(0, 0) = 5
  147.         m2w(1, 1) = 5
  148.         m2w(2, 2) = 0.5
  149.         m2w(3, 3) = 1
  150.     End If
  151.  
  152.     If aniList Is Nothing Then
  153.         Exit Sub
  154.     End If
  155.  
  156. again:
  157.     If stepNo < 10 Then
  158.         stepNo = stepNo + 1
  159.         m2w(2, 2) = m2w(2, 2) + 0.5
  160.     ElseIf stepNo < 20 Then
  161.         stepNo = stepNo + 1
  162.         m2w(2, 2) = m2w(2, 2) - 0.5
  163.     Else
  164.         stepNo = 0
  165.         GoTo again
  166.     End If
  167.     Dim ot As ArCon.ObjectTransformer
  168.     For Each ot In aniList
  169.         ot.matrix = m2w
  170.     Next
  171.     aniList.Update False
  172. End Sub
  173.  
  174. Private Sub GenTorus()
  175.     Dim cth As Single, cah As Single, dct As Single, dst As Single, st As Single
  176.     Dim ct As Single, ct1 As Single, st1 As Single, dca As Single
  177.     Dim dsa As Single, ca As Single, sa As Single
  178.     Dim a As Integer, t As Integer, ap As Integer, tp As Integer
  179.     Dim oldMode As Long
  180.     
  181.     oldMode = Main.ArConEXE.MultiUserMode
  182.     Main.ArConEXE.MultiUserMode = oldMode And Not (ACMU_NICE Or ACMU_UIENABLED)
  183.  
  184.     dct = Cos(twoPi / facX)
  185.     dst = Sqr(1 - (dct * dct))
  186.     dca = Cos(twoPi / facY)
  187.     dsa = Sqr(1 - (dca * dca))
  188.     ca = rRat
  189.     sa = 0
  190.     Main.ArConEXE.SetProgressbarSubTitle "Punktkoordinaten berechnen"
  191.     For a = 0 To facY - 1
  192.         Main.ArConEXE.SetProgressbarValue a * 10 / facY
  193.         ct = 1 + sa
  194.         st = 0
  195.         ct1 = 1
  196.         st1 = 0
  197.         For t = 0 To facX - 1
  198.             ps(a, t).u = t * 3 / facX
  199.             ps(a, t).v = a * 3 / facY
  200.             ps(a, t).x = ct
  201.             ps(a, t).y = st
  202.             ps(a, t).z = ca
  203.             cth = ct
  204.             ct = ct * dct - st * dst
  205.             st = st * dct + cth * dst
  206.             cth = ct1
  207.             ct1 = ct1 * dct - st1 * dst
  208.             st1 = st1 * dct + cth * dst
  209.         Next
  210.         cah = ca
  211.         ca = ca * dca - sa * dsa
  212.         sa = sa * dca + cah * dsa
  213.     Next
  214.     Main.ArConEXE.SetProgressbarSubTitle "FlΣchen erzeugen"
  215.     For a = 0 To facY - 1
  216.         Main.ArConEXE.SetProgressbarValue 10 + a * 90 / facY
  217.         ap = a + 1
  218.         If ap >= facY Then ap = 0
  219.         For t = 0 To facX - 1
  220.             tp = t + 1
  221.             If tp >= facX Then tp = 0
  222.             GenQuad a, t, ap, tp
  223.         Next
  224.     Next
  225.     Main.ArConEXE.SetProgressbarValue 100
  226.     Main.ArConEXE.MultiUserMode = oldMode
  227. End Sub
  228.  
  229. Private Sub GenQuad(a As Integer, t As Integer, ap As Integer, tp As Integer)
  230.     Dim contur(4, 3) As Single
  231. #If HasHoles Then
  232.     Dim hp As Punkt, hp2 As Punkt
  233.     Dim loch(4, 3) As Single, loch2(4, 3) As Single
  234.     Dim d As Single
  235. #End If
  236.  
  237.     contur(0, 0) = ps(a, t).x
  238.     contur(1, 0) = ps(a, t).y
  239.     contur(2, 0) = ps(a, t).z
  240.     contur(3, 0) = ps(a, t).u
  241.     contur(4, 0) = ps(a, t).v
  242. #If HasHoles Then
  243.     d = (ps(ap, t).x - ps(a, t).x) + (ps(a, tp).x - ps(a, t).x)
  244.     hp.x = ps(a, t).x + d * FAK
  245.     hp2.x = ps(a, t).x + d * FAK2
  246.     d = (ps(ap, t).y - ps(a, t).y) + (ps(a, tp).y - ps(a, t).y)
  247.     hp.y = ps(a, t).y + d * FAK
  248.     hp2.y = ps(a, t).y + d * FAK2
  249.     d = (ps(ap, t).z - ps(a, t).z) + (ps(a, tp).z - ps(a, t).z)
  250.     hp.z = ps(a, t).z + d * FAK
  251.     hp2.z = ps(a, t).z + d * FAK2
  252.     d = (ps(ap, t).u - ps(a, t).u) + (ps(a, tp).u - ps(a, t).u)
  253.     hp.u = ps(a, t).u + d * FAK
  254.     hp2.u = ps(a, t).u + d * FAK2
  255.     d = (ps(ap, t).v - ps(a, t).v) + (ps(a, tp).v - ps(a, t).v)
  256.     hp.v = ps(a, t).v + d * FAK
  257.     hp2.v = ps(a, t).v + d * FAK2
  258.     loch(0, 0) = hp.x
  259.     loch(1, 0) = hp.y
  260.     loch(2, 0) = hp.z
  261.     loch(3, 0) = hp.u
  262.     loch(4, 0) = hp.v
  263.     loch(0, 1) = hp2.x
  264.     loch(1, 1) = hp2.y
  265.     loch(2, 1) = hp2.z
  266.     loch(3, 1) = hp2.u
  267.     loch(4, 1) = hp2.v
  268.  #End If
  269.     contur(0, 1) = ps(ap, t).x
  270.     contur(1, 1) = ps(ap, t).y
  271.     contur(2, 1) = ps(ap, t).z
  272.     contur(3, 1) = ps(ap, t).u
  273.     contur(4, 1) = ps(ap, t).v
  274. #If HasHoles Then
  275.     d = (ps(ap, tp).x - ps(ap, t).x) + (ps(a, t).x - ps(ap, t).x)
  276.     hp.x = ps(ap, t).x + d * FAK
  277.     hp2.x = ps(ap, t).x + d * FAK2
  278.     d = (ps(ap, tp).y - ps(ap, t).y) + (ps(a, t).y - ps(ap, t).y)
  279.     hp.y = ps(ap, t).y + d * FAK
  280.     hp2.y = ps(ap, t).y + d * FAK2
  281.     d = (ps(ap, tp).z - ps(ap, t).z) + (ps(a, t).z - ps(ap, t).z)
  282.     hp.z = ps(ap, t).z + d * FAK
  283.     hp2.z = ps(ap, t).z + d * FAK2
  284.     d = (ps(ap, tp).u - ps(ap, t).u) + (ps(a, t).u - ps(ap, t).u)
  285.     hp.u = ps(ap, t).u + d * FAK
  286.     hp2.u = ps(ap, t).u + d * FAK2
  287.     d = (ps(ap, tp).v - ps(ap, t).v) + (ps(a, t).v - ps(ap, t).v)
  288.     hp.v = ps(ap, t).v + d * FAK
  289.     hp2.v = ps(ap, t).v + d * FAK2
  290.     loch2(0, 0) = hp.x
  291.     loch2(1, 0) = hp.y
  292.     loch2(2, 0) = hp.z
  293.     loch2(3, 0) = hp.u
  294.     loch2(4, 0) = hp.v
  295.     loch2(0, 3) = hp2.x
  296.     loch2(1, 3) = hp2.y
  297.     loch2(2, 3) = hp2.z
  298.     loch2(3, 3) = hp2.u
  299.     loch2(4, 3) = hp2.v
  300. #End If
  301.     contur(0, 2) = ps(ap, tp).x
  302.     contur(1, 2) = ps(ap, tp).y
  303.     contur(2, 2) = ps(ap, tp).z
  304.     contur(3, 2) = ps(ap, tp).u
  305.     contur(4, 2) = ps(ap, tp).v
  306. #If HasHoles Then
  307.     d = (ps(a, tp).x - ps(ap, tp).x) + (ps(ap, t).x - ps(ap, tp).x)
  308.     hp.x = ps(ap, tp).x + d * FAK
  309.     hp2.x = ps(ap, tp).x + d * FAK2
  310.     d = (ps(a, tp).y - ps(ap, tp).y) + (ps(ap, t).y - ps(ap, tp).y)
  311.     hp.y = ps(ap, tp).y + d * FAK
  312.     hp2.y = ps(ap, tp).y + d * FAK2
  313.     d = (ps(a, tp).z - ps(ap, tp).z) + (ps(ap, t).z - ps(ap, tp).z)
  314.     hp.z = ps(ap, tp).z + d * FAK
  315.     hp2.z = ps(ap, tp).z + d * FAK2
  316.     d = (ps(a, tp).u - ps(ap, tp).u) + (ps(ap, t).u - ps(ap, tp).u)
  317.     hp.u = ps(ap, tp).u + d * FAK
  318.     hp2.u = ps(ap, tp).u + d * FAK2
  319.     d = (ps(a, tp).v - ps(ap, tp).v) + (ps(ap, t).v - ps(ap, tp).v)
  320.     hp.v = ps(ap, tp).v + d * FAK
  321.     hp2.v = ps(ap, tp).v + d * FAK2
  322.     loch2(0, 1) = hp.x
  323.     loch2(1, 1) = hp.y
  324.     loch2(2, 1) = hp.z
  325.     loch2(3, 1) = hp.u
  326.     loch2(4, 1) = hp.v
  327.     loch2(0, 2) = hp2.x
  328.     loch2(1, 2) = hp2.y
  329.     loch2(2, 2) = hp2.z
  330.     loch2(3, 2) = hp2.u
  331.     loch2(4, 2) = hp2.v
  332. #End If
  333.     contur(0, 3) = ps(a, tp).x
  334.     contur(1, 3) = ps(a, tp).y
  335.     contur(2, 3) = ps(a, tp).z
  336.     contur(3, 3) = ps(a, tp).u
  337.     contur(4, 3) = ps(a, tp).v
  338. #If HasHoles Then
  339.     d = (ps(a, t).x - ps(a, tp).x) + (ps(ap, tp).x - ps(a, tp).x)
  340.     hp.x = ps(a, tp).x + d * FAK
  341.     hp2.x = ps(a, tp).x + d * FAK2
  342.     d = (ps(a, t).y - ps(a, tp).y) + (ps(ap, tp).y - ps(a, tp).y)
  343.     hp.y = ps(a, tp).y + d * FAK
  344.     hp2.y = ps(a, tp).y + d * FAK2
  345.     d = (ps(a, t).z - ps(a, tp).z) + (ps(ap, tp).z - ps(a, tp).z)
  346.     hp.z = ps(a, tp).z + d * FAK
  347.     hp2.z = ps(a, tp).z + d * FAK2
  348.     d = (ps(a, t).u - ps(a, tp).u) + (ps(ap, tp).u - ps(a, tp).u)
  349.     hp.u = ps(a, tp).u + d * FAK
  350.     hp2.u = ps(a, tp).u + d * FAK2
  351.     d = (ps(a, t).v - ps(a, tp).v) + (ps(ap, tp).v - ps(a, tp).v)
  352.     hp.v = ps(a, tp).v + d * FAK
  353.     hp2.v = ps(a, tp).v + d * FAK2
  354.     loch(0, 3) = hp.x
  355.     loch(1, 3) = hp.y
  356.     loch(2, 3) = hp.z
  357.     loch(3, 3) = hp.u
  358.     loch(4, 3) = hp.v
  359.     loch(0, 2) = hp2.x
  360.     loch(1, 2) = hp2.y
  361.     loch(2, 2) = hp2.z
  362.     loch(3, 2) = hp2.u
  363.     loch(4, 2) = hp2.v
  364. #End If
  365.     constr.SetHoleContur 0, 4, contur
  366. #If HasHoles Then
  367.     constr.SetHoleContur 1, 4, loch
  368.     constr.SetHoleContur 2, 4, loch2
  369. #End If
  370.     constr.AddPolygonWithHoles False, mat, theTexture
  371. End Sub
  372.  
  373. Public Sub CleanUp()
  374.     Set aniList = Nothing
  375.     Set mat = Nothing
  376.     Set constr = Nothing
  377.     Set Instance = Nothing
  378. End Sub
  379.