home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
The Houseplan Collection
/
HRCD2005.ISO
/
data1.cab
/
Zusatz
/
3DS
/
DATA2.Z
/
Torus.bas
< prev
next >
Wrap
BASIC Source File
|
1999-01-27
|
12KB
|
379 lines
Attribute VB_Name = "Torus"
' MS Visual Basic Demo-Programm zur Demonstration der ActiveX-FΣhigkeit
' von ArCon(+).
'
' Der abgebildete Code dient lediglich Demonstrationszwecken.
' Es wird keinerlei Garantie fⁿr die Richtigkeit und/oder
' FunktionsfΣhigkeit ⁿbernommen. Bei Fragen wenden Sie sich bitte an
'
' mb-Programme
' Software im Bauwesen GmbH
' Hermannstra▀e 1
' D-31785 Hameln
' e-mail: arcon@mb-hameln.de
' Internet http://www.mb-hameln.de
Option Explicit
#Const HasHoles = 0 ' Erzeuge Polygone ohne L÷chern
Declare Function GetTickCount Lib "Kernel32" () As Long
Private Const pi As Single = 3.1415926
Private Const twoPi As Single = pi * 2
Private Const facX As Integer = 30
Private Const facY As Integer = 16
Private Const rRat As Single = 0.8
Private Const FAK As Single = 0.2
Private Const FAK2 As Single = 0.3
Private Const theTexture As String = ">wand\tapete\kinder\kaefer1.bmp"
Private constr As ArCon.ObjectConstructor
Private mat As ArCon.Material, Instance As ArCon.Object3D
Private aniList As ArCon.ObjectTransformerCollection
Private Type Punkt
x As Single
y As Single
z As Single
u As Single
v As Single
End Type
Private ps(facY, facX) As Punkt
Public Sub StopTest()
Set aniList = Nothing
End Sub
Public Sub DoTest()
Set constr = Main.ArConEXE.NewObjectConstructor(0, twoPi / 360 * 105)
Set mat = Main.ArConEXE.NewMaterial
mat.AmbientCoefficient = 0.2
mat.DiffuseCoefficient = 0.4
mat.SpecularCoefficient = 0.4
mat.DiffuseColor = RGB(255, 255, 255)
mat.SpecularColor = RGB(255, 255, 255)
mat.Transparent = False
#If HasHoles Then
mat.Flags = ACMATFL_ISTEXTURED + ACMATFL_TWOSIDED
#Else
mat.Flags = ACMATFL_ISTEXTURED
#End If
Dim t1 As Long, t2 As Long
Main.ArConEXE.StartProgressbar "Erzeuge einen Torus", 0
t1 = GetTickCount()
GenTorus
t2 = GetTickCount
Main.ArConEXE.SetProgressbarSubTitle "Nachbarschaften & Normalen berechnen"
constr.Finish "Der Torus", False, ACO_DURATION_CACHEABLE
Main.ArConEXE.StopProgressbar
Main.ArConEXE.SetStatusText CStr(t2 - t1) & " ms"
Dim m2w(3, 3) As Single
Dim l As ArCon.Label
Dim i As Integer, j As Integer
For i = 0 To 3
For j = 0 To 3
m2w(i, j) = 0
Next
Next
m2w(0, 0) = 5
m2w(1, 1) = 5
m2w(2, 2) = 0.5
m2w(3, 3) = 1
Set Instance = constr.Create(Nothing, False)
If Instance Is Nothing Then
MsgBox "Konstruktion des Torus ist fehlgeschlagen"
End
End If
Instance.Flags = AC_3DFL_DBLCLICK Or AC_3DFL_CONSTMODE Or AC_3DFL_DESIGNMODE Or AC_3DFL_SHOWALL
Instance.SetModelToWorldTransformation m2w
' Ein 3D-Objekt mit 2D Ersatzdarstellung darf nicht (zusΣtzlich)
' in die Welt eingefⁿgt werden, da es bereits ⁿber das zugeorndete
' 2D-Objekt verwaltet wird.
' Ansonsten wⁿrde hier folgen:
' Instance.InsertIntoWorld False
Set l = Main.ArConEXE.NewLabel(AC_LayerLast)
l.Caption = "Ein Torus"
With l.Font
.Name = "Arial"
.Size = 12
.Bold = True
.Italic = True
End With
l.Left = 1
l.Top = 2
l.Width = 2
l.Height = 0.5
l.Angle = 0.3
l.Visible = True
l.Selectable = True
Main.ArConEXE.CurrentStory.Graphics2D.Add l
Instance.SetOutline2D l, LoadResPicture(1, vbResCursor), "ACHTUNG: hier nicht klicken!"
Main.ArConEXE.Redraw3DViews
' Set aniList = Main.ArConEXE.NewObjectTransformerCollection
' aniList.Add Instance, m2w
' Set mat = Nothing
' Der ObjectConstructor darf erst freigegeben werden, wenn es keine daraus
' konstruierten Objekte mehr gibt. Daher ist folgendes falsch:
' Set constr = Nothing
End Sub
Public Sub DoStep()
Static initDone As Boolean
Static m2w(3, 3) As Single
Static stepNo As Integer
If Not initDone Then
Dim i As Integer, j As Integer
initDone = True
stepNo = 0
For i = 0 To 3
For j = 0 To 3
m2w(i, j) = 0
Next
Next
m2w(0, 0) = 5
m2w(1, 1) = 5
m2w(2, 2) = 0.5
m2w(3, 3) = 1
End If
If aniList Is Nothing Then
Exit Sub
End If
again:
If stepNo < 10 Then
stepNo = stepNo + 1
m2w(2, 2) = m2w(2, 2) + 0.5
ElseIf stepNo < 20 Then
stepNo = stepNo + 1
m2w(2, 2) = m2w(2, 2) - 0.5
Else
stepNo = 0
GoTo again
End If
Dim ot As ArCon.ObjectTransformer
For Each ot In aniList
ot.matrix = m2w
Next
aniList.Update False
End Sub
Private Sub GenTorus()
Dim cth As Single, cah As Single, dct As Single, dst As Single, st As Single
Dim ct As Single, ct1 As Single, st1 As Single, dca As Single
Dim dsa As Single, ca As Single, sa As Single
Dim a As Integer, t As Integer, ap As Integer, tp As Integer
Dim oldMode As Long
oldMode = Main.ArConEXE.MultiUserMode
Main.ArConEXE.MultiUserMode = oldMode And Not (ACMU_NICE Or ACMU_UIENABLED)
dct = Cos(twoPi / facX)
dst = Sqr(1 - (dct * dct))
dca = Cos(twoPi / facY)
dsa = Sqr(1 - (dca * dca))
ca = rRat
sa = 0
Main.ArConEXE.SetProgressbarSubTitle "Punktkoordinaten berechnen"
For a = 0 To facY - 1
Main.ArConEXE.SetProgressbarValue a * 10 / facY
ct = 1 + sa
st = 0
ct1 = 1
st1 = 0
For t = 0 To facX - 1
ps(a, t).u = t * 3 / facX
ps(a, t).v = a * 3 / facY
ps(a, t).x = ct
ps(a, t).y = st
ps(a, t).z = ca
cth = ct
ct = ct * dct - st * dst
st = st * dct + cth * dst
cth = ct1
ct1 = ct1 * dct - st1 * dst
st1 = st1 * dct + cth * dst
Next
cah = ca
ca = ca * dca - sa * dsa
sa = sa * dca + cah * dsa
Next
Main.ArConEXE.SetProgressbarSubTitle "FlΣchen erzeugen"
For a = 0 To facY - 1
Main.ArConEXE.SetProgressbarValue 10 + a * 90 / facY
ap = a + 1
If ap >= facY Then ap = 0
For t = 0 To facX - 1
tp = t + 1
If tp >= facX Then tp = 0
GenQuad a, t, ap, tp
Next
Next
Main.ArConEXE.SetProgressbarValue 100
Main.ArConEXE.MultiUserMode = oldMode
End Sub
Private Sub GenQuad(a As Integer, t As Integer, ap As Integer, tp As Integer)
Dim contur(4, 3) As Single
#If HasHoles Then
Dim hp As Punkt, hp2 As Punkt
Dim loch(4, 3) As Single, loch2(4, 3) As Single
Dim d As Single
#End If
contur(0, 0) = ps(a, t).x
contur(1, 0) = ps(a, t).y
contur(2, 0) = ps(a, t).z
contur(3, 0) = ps(a, t).u
contur(4, 0) = ps(a, t).v
#If HasHoles Then
d = (ps(ap, t).x - ps(a, t).x) + (ps(a, tp).x - ps(a, t).x)
hp.x = ps(a, t).x + d * FAK
hp2.x = ps(a, t).x + d * FAK2
d = (ps(ap, t).y - ps(a, t).y) + (ps(a, tp).y - ps(a, t).y)
hp.y = ps(a, t).y + d * FAK
hp2.y = ps(a, t).y + d * FAK2
d = (ps(ap, t).z - ps(a, t).z) + (ps(a, tp).z - ps(a, t).z)
hp.z = ps(a, t).z + d * FAK
hp2.z = ps(a, t).z + d * FAK2
d = (ps(ap, t).u - ps(a, t).u) + (ps(a, tp).u - ps(a, t).u)
hp.u = ps(a, t).u + d * FAK
hp2.u = ps(a, t).u + d * FAK2
d = (ps(ap, t).v - ps(a, t).v) + (ps(a, tp).v - ps(a, t).v)
hp.v = ps(a, t).v + d * FAK
hp2.v = ps(a, t).v + d * FAK2
loch(0, 0) = hp.x
loch(1, 0) = hp.y
loch(2, 0) = hp.z
loch(3, 0) = hp.u
loch(4, 0) = hp.v
loch(0, 1) = hp2.x
loch(1, 1) = hp2.y
loch(2, 1) = hp2.z
loch(3, 1) = hp2.u
loch(4, 1) = hp2.v
#End If
contur(0, 1) = ps(ap, t).x
contur(1, 1) = ps(ap, t).y
contur(2, 1) = ps(ap, t).z
contur(3, 1) = ps(ap, t).u
contur(4, 1) = ps(ap, t).v
#If HasHoles Then
d = (ps(ap, tp).x - ps(ap, t).x) + (ps(a, t).x - ps(ap, t).x)
hp.x = ps(ap, t).x + d * FAK
hp2.x = ps(ap, t).x + d * FAK2
d = (ps(ap, tp).y - ps(ap, t).y) + (ps(a, t).y - ps(ap, t).y)
hp.y = ps(ap, t).y + d * FAK
hp2.y = ps(ap, t).y + d * FAK2
d = (ps(ap, tp).z - ps(ap, t).z) + (ps(a, t).z - ps(ap, t).z)
hp.z = ps(ap, t).z + d * FAK
hp2.z = ps(ap, t).z + d * FAK2
d = (ps(ap, tp).u - ps(ap, t).u) + (ps(a, t).u - ps(ap, t).u)
hp.u = ps(ap, t).u + d * FAK
hp2.u = ps(ap, t).u + d * FAK2
d = (ps(ap, tp).v - ps(ap, t).v) + (ps(a, t).v - ps(ap, t).v)
hp.v = ps(ap, t).v + d * FAK
hp2.v = ps(ap, t).v + d * FAK2
loch2(0, 0) = hp.x
loch2(1, 0) = hp.y
loch2(2, 0) = hp.z
loch2(3, 0) = hp.u
loch2(4, 0) = hp.v
loch2(0, 3) = hp2.x
loch2(1, 3) = hp2.y
loch2(2, 3) = hp2.z
loch2(3, 3) = hp2.u
loch2(4, 3) = hp2.v
#End If
contur(0, 2) = ps(ap, tp).x
contur(1, 2) = ps(ap, tp).y
contur(2, 2) = ps(ap, tp).z
contur(3, 2) = ps(ap, tp).u
contur(4, 2) = ps(ap, tp).v
#If HasHoles Then
d = (ps(a, tp).x - ps(ap, tp).x) + (ps(ap, t).x - ps(ap, tp).x)
hp.x = ps(ap, tp).x + d * FAK
hp2.x = ps(ap, tp).x + d * FAK2
d = (ps(a, tp).y - ps(ap, tp).y) + (ps(ap, t).y - ps(ap, tp).y)
hp.y = ps(ap, tp).y + d * FAK
hp2.y = ps(ap, tp).y + d * FAK2
d = (ps(a, tp).z - ps(ap, tp).z) + (ps(ap, t).z - ps(ap, tp).z)
hp.z = ps(ap, tp).z + d * FAK
hp2.z = ps(ap, tp).z + d * FAK2
d = (ps(a, tp).u - ps(ap, tp).u) + (ps(ap, t).u - ps(ap, tp).u)
hp.u = ps(ap, tp).u + d * FAK
hp2.u = ps(ap, tp).u + d * FAK2
d = (ps(a, tp).v - ps(ap, tp).v) + (ps(ap, t).v - ps(ap, tp).v)
hp.v = ps(ap, tp).v + d * FAK
hp2.v = ps(ap, tp).v + d * FAK2
loch2(0, 1) = hp.x
loch2(1, 1) = hp.y
loch2(2, 1) = hp.z
loch2(3, 1) = hp.u
loch2(4, 1) = hp.v
loch2(0, 2) = hp2.x
loch2(1, 2) = hp2.y
loch2(2, 2) = hp2.z
loch2(3, 2) = hp2.u
loch2(4, 2) = hp2.v
#End If
contur(0, 3) = ps(a, tp).x
contur(1, 3) = ps(a, tp).y
contur(2, 3) = ps(a, tp).z
contur(3, 3) = ps(a, tp).u
contur(4, 3) = ps(a, tp).v
#If HasHoles Then
d = (ps(a, t).x - ps(a, tp).x) + (ps(ap, tp).x - ps(a, tp).x)
hp.x = ps(a, tp).x + d * FAK
hp2.x = ps(a, tp).x + d * FAK2
d = (ps(a, t).y - ps(a, tp).y) + (ps(ap, tp).y - ps(a, tp).y)
hp.y = ps(a, tp).y + d * FAK
hp2.y = ps(a, tp).y + d * FAK2
d = (ps(a, t).z - ps(a, tp).z) + (ps(ap, tp).z - ps(a, tp).z)
hp.z = ps(a, tp).z + d * FAK
hp2.z = ps(a, tp).z + d * FAK2
d = (ps(a, t).u - ps(a, tp).u) + (ps(ap, tp).u - ps(a, tp).u)
hp.u = ps(a, tp).u + d * FAK
hp2.u = ps(a, tp).u + d * FAK2
d = (ps(a, t).v - ps(a, tp).v) + (ps(ap, tp).v - ps(a, tp).v)
hp.v = ps(a, tp).v + d * FAK
hp2.v = ps(a, tp).v + d * FAK2
loch(0, 3) = hp.x
loch(1, 3) = hp.y
loch(2, 3) = hp.z
loch(3, 3) = hp.u
loch(4, 3) = hp.v
loch(0, 2) = hp2.x
loch(1, 2) = hp2.y
loch(2, 2) = hp2.z
loch(3, 2) = hp2.u
loch(4, 2) = hp2.v
#End If
constr.SetHoleContur 0, 4, contur
#If HasHoles Then
constr.SetHoleContur 1, 4, loch
constr.SetHoleContur 2, 4, loch2
#End If
constr.AddPolygonWithHoles False, mat, theTexture
End Sub
Public Sub CleanUp()
Set aniList = Nothing
Set mat = Nothing
Set constr = Nothing
Set Instance = Nothing
End Sub