Option Explicit
Const vbdMissing = -2
Sub main()
Dim u As Integer, f As Integer, v As Integer, anzahl As Integer
Dim holder As Acad3DSolid
Dim tempList As Variant
Dim koordList() As Variant
Dim xKoord() As Variant
Dim koord(0 To 2) As Double
Randomize
anzahl = 200
ReDim xKoord(anzahl) As Variant
ReDim koordList(anzahl) As Variant
'Positioniert die Kugeln
For v = 0 To anzahl
koord(0) = random(0#, 1000#): koord(1) = random(0#, 800#): koord(2)
= 0
kugel koord, 2
koordList(v) = koord
xKoord(v) = koord(0)
Next v
funQsort xKoord
' koordList nach xKoord umsortieren
While u <= anzahl
For f = 0 + u To anzahl
If koordList(f)(0) = xKoord(u) Then
tempList = koordList(u)
koordList(u) = koordList(f)
koordList(f) = tempList
u = u + 1
End If
Next f
Wend
Dim z As Integer, i As Integer
Dim zaehler As Double, deltaWinkA As Double, winkB As Double, arkWink
As Double, refWi As Double
Dim highP() As Variant, ergebnis() As Variant
Dim vektorA(0 To 2) As Double, vektorB(0 To 2) As Double
Dim startP(0 To 2) As Double, endP(0 To 2) As Double
Dim richtung As Boolean
startP(0) = koordList(0)(0): startP(1) = koordList(0)(1):
startP(2) = koordList(0)(2)
richtung = True
Do
refWi = 0
ReDim ergebnis(anzahl) As Variant
ReDim highP(anzahl) As Variant
For i = 0 To anzahl
If Not (startP(0) = koordList(i)(0) And startP(1) = koordList(i)(1))
Then
vektorA(0) = koordList(i)(0) - startP(0): vektorA(1) = koordList(i)(1)
- startP(1)
deltaWinkA = vektorA(0) / Sqr(vektorA(0) ^ 2 + vektorA(1) ^ 2)
If startP(0) >= koordList(anzahl)(0) Then richtung = False
If richtung Then
If koordList(i)(0) >= startP(0) Then
If koordList(i)(1) <= startP(1) Then
ergebnis(i) = 360 - arkusKos(deltaWinkA) * (180 / pi) - 270
Else
ergebnis(i) = arkusKos(deltaWinkA) * (180 / pi) + 90
End If
If refWi < ergebnis(i) Then
refWi = ergebnis(i)
highP(z) = koordList(i)
End If
End If
Else
If koordList(i)(0) <= startP(0) Then
If koordList(i)(1) <= startP(1) Then
ergebnis(i) = 360 - arkusKos(deltaWinkA) * (180 / pi) - 90
Else
ergebnis(i) = arkusKos(deltaWinkA) * (180 / pi) - 90
End If
If refWi <= ergebnis(i) Then
refWi = ergebnis(i)
highP(z) = koordList(i)
End If
End If
End If
End If
Next i
endP(0) = highP(z)(0): endP(1) = highP(z)(1): endP(2)
= highP(z)(2)
draw_line startP, endP, z
startP(0) = highP(z)(0): startP(1) = highP(z)(1): startP(2) = highP(z)(2)
z = z + 1
Loop While Not (startP(0) = koordList(0)(0) And startP(1) = koordList(0)(1))
End Sub
Sub kugel(location As Variant, col As Integer)
Dim pointObj As Acad3DSolid
Dim radius As Double
radius = 2
Set pointObj = ThisDrawing.ModelSpace.AddSphere(location, radius)
pointObj.color = col
ZoomAll
End Sub
Sub draw_line(here() As Double, there() As Double,
col As Integer) '---zeichnen der Verbindungslinie
Dim begin(2) As Double, finish(2) As Double
Dim path As AcadLine
'---Linie zeichnen
Set path = ThisDrawing.ModelSpace.AddLine(here, there)
path.color = col
path.Update
End Sub
Function arkusKos(wert As Double) '---arcusKosinus
berechnen
If wert = 1 Then arkusKos = 0
If wert = -1 Then arkusKos = 180
If wert < 1 And wert > -1 Then arkusKos = Atn(-wert / Sqr(-wert
* wert + 1)) + 2 * Atn(1)
End Function
Function random(lower As Double, upper As Double)
'---Erzeugen eines Zufallswertes
random = Int((upper - lower + 1) * Rnd + lower)
End Function
Function pi() '---Berechnung der Zahl Pi
pi = (Atn(1) * 4)
End Function
'Sortiermethode
Sub funQsort(varArray As Variant, Optional intLeft As Integer =
vbdMissing, Optional intRight As Integer = vbdMissing)
Dim intCnt As Integer
Dim intStep As Integer
Dim varTestVal As Variant
Dim intMid As Integer
If intLeft = vbdMissing Then intLeft = LBound(varArray)
If intRight = vbdMissing Then intRight = UBound(varArray)
If intLeft < intRight Then
intMid = (intLeft + intRight) \ 2
varTestVal = varArray(intMid)
intCnt = intLeft
intStep = intRight
Do
Do While varArray(intCnt) < varTestVal
intCnt = intCnt + 1
Loop
Do While varArray(intStep) > varTestVal
intStep = intStep - 1
Loop
If intCnt <= intStep Then
SwapElements varArray, intCnt, intStep
intCnt = intCnt + 1
intStep = intStep - 1
End If
Loop Until intCnt > intStep
If intStep <= intMid Then
Call funQsort(varArray, intLeft, intStep)
Call funQsort(varArray, intCnt, intRight)
Else
Call funQsort(varArray, intCnt, intRight)
Call funQsort(varArray, intLeft, intStep)
End If
End If
End Sub
Private Sub SwapElements(varItems As Variant, intItem1
As Integer, intItem2 As Integer)
Dim varTemp As Variant
varTemp = varItems(intItem2)
varItems(intItem2) = varItems(intItem1)
varItems(intItem1) = varTemp
End Sub
|