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