Sub Biegetabelle()

    On Error GoTo 1

    ThisApplication.StatusBarText = "Biegetabelle wird berechnet. Bitte warten..."

    Dim oDrawDoc As DrawingDocument
    Set oDrawDoc = ThisApplication.ActiveDocument
    
    Dim oSheet As Sheet
    Set oSheet = oDrawDoc.ActiveSheet
    
    Dim oAssDoc As AssemblyDocument
    Set oAssDoc = oDrawDoc.AllReferencedDocuments(1)
    
    Dim oPipeDoc As PartDocument
    Set oPipeDoc = oAssDoc.AllReferencedDocuments(1)
    
    Dim SKA As Sketch3D
    Set SKA = oPipeDoc.ComponentDefinition.Sketches3D(1)
    
    Dim oTG As TransientGeometry
    Set oTG = ThisApplication.TransientGeometry
    
    Dim Numberofpoints As Double
    Numberofpoints = SKA.SketchPoints3D.Count
    
    If Numberofpoints < 4 Then
        MsgBox "The Pipe must have at least one bend! Makro will be cancelled", vbCritical, "Piping Makro"
        Exit Sub
    End If
    
    Dim oTable As CustomTable
    
    Dim Columns(4) As String
    Columns(0) = "Punkt" & vbCrLf & "point"
    Columns(1) = "X"
    Columns(2) = "Y"
    Columns(3) = "Z"
    Columns(4) = "Biegeradius" & vbCrLf & "bending radius"

    Dim oColumnWidths(4) As Double
    oColumnWidths(0) = 1.1
    oColumnWidths(1) = 2
    oColumnWidths(2) = 2
    oColumnWidths(3) = 2
    oColumnWidths(4) = 2.5
    
    'Prüfen ob eine Tabelle bereits auf dem Blatt ist...
    Dim tableExists As Boolean
    tableExists = False

    Dim i As Long 'Laufvariable
    For Each oTable In oSheet.CustomTables
        If oTable.Title = "Biegetabelle / bending table" Then
            tableExists = True
            Dim oRow As Row
            For Each oRow In oTable.Rows
                oRow.Delete
            Next
            For i = 0 To 4
                oTable.Columns(i + 1).Title = Columns(i)
            Next i
            Exit For
        End If
    Next
    
    If tableExists = False Then
        Set oTable = oSheet.CustomTables.Add("Biegetabelle / bending table", oTG.CreatePoint2d(2.5, oSheet.Height - 3), 5, 1, Columns, , oColumnWidths)
    End If
    
    'Tabelle formatieren
    oTable.ShowTitle = False
    
    ' Ausrichtung Spaltenköpfe
    For i = 1 To 5
        oTable.Columns(i).ValueHorizontalJustification = kAlignTextCenter
        oTable.Columns(i).TitleHorizontalJustification = kAlignTextCenter
    Next i
     
    'Startpunkt Rohr
    Dim oOrigin As Point
    Set oOrigin = SKA.SketchPoints3D(1).Geometry
    
    'X-Achse entlang erstem Rohrstück
    Dim oXAxis As Vector
    Set oXAxis = SKA.SketchPoints3D(1).Geometry.VectorTo(SKA.SketchPoints3D(2).Geometry)
    
    'Z-Achse als Kreuzprodukt X-Achsenvektor und Vektor Punkt 1 und Punkt 4
    Dim oZAxis As Vector
    Set oZAxis = oXAxis.CrossProduct(SKA.SketchPoints3D(1).Geometry.VectorTo(SKA.SketchPoints3D(3).Geometry))
    
    'Y-Achse als Kreuzprodukt aus X- und Z-Achsenvector
    Dim oYAxis As Vector
    Set oYAxis = oZAxis.CrossProduct(oXAxis)
    
    ' Normalisieren der Vektorlängen
    Call oXAxis.Normalize
    Call oYAxis.Normalize
    Call oZAxis.Normalize
    
    'Matrix des Koordinatensystems
    Dim oMatrix As Matrix
    Set oMatrix = oTG.CreateMatrix
    
    'Matrix des Anfangspunktes
    Dim oMatrix2 As Matrix
    Set oMatrix2 = oTG.CreateMatrix
    Call oMatrix2.SetCoordinateSystem(oOrigin, oXAxis, oYAxis, oZAxis)
    
    Call oMatrix.PreMultiplyBy(oMatrix2)
    
    Call oMatrix.Invert
    
    Dim myTable(1 To 99, 1 To 5) As Variant
    Dim j As Double 'Laufvariable2
    
    i = 0
    Dim oSKPoint As SketchPoint3D
    For Each oSKPoint In SKA.SketchPoints3D
        Dim oPoint As Point
        If oSKPoint.AttachedEntities.Count = 1 Then
            i = i + 1
            myTable(i, 1) = "P" & CStr(i)
            
            Set oPoint = oSKPoint.Geometry
            Call oPoint.TransformBy(oMatrix)
            
            myTable(i, 2) = Round(oPoint.x * 20, 0) / 2
            myTable(i, 3) = Round(oPoint.Y * 20, 0) / 2
            myTable(i, 4) = Round(oPoint.Z * 20, 0) / 2
        ElseIf (oSKPoint.AttachedEntities(1).Type = kSketchLine3DObject And oSKPoint.AttachedEntities(2).Type = kSketchLine3DObject) Then
            i = i + 1
            j = j + 1
            myTable(i, 1) = "P" & CStr(i)
            
            Set oPoint = oSKPoint.Geometry
            Call oPoint.TransformBy(oMatrix)
            
            myTable(i, 2) = Round(oPoint.x * 20, 0) / 2
            myTable(i, 3) = Round(oPoint.Y * 20, 0) / 2
            myTable(i, 4) = Round(oPoint.Z * 20, 0) / 2
            
            Dim oArc As SketchArc3D
            Set oArc = SKA.SketchArcs3D(j)

            myTable(i, 5) = Round(oArc.Radius * 20, 0) / 2
        End If
    Next

'Werte in Tabelle Schreiben
For i = 1 To UBound(myTable)
    If myTable(i, 1) = "" Then Exit For
    
    If oTable.Rows.Count < i Then
        oTable.Rows.Add
    End If
    oTable.Rows.Item(i).Item(1).Value = myTable(i, 1)
    oTable.Rows.Item(i).Item(2).Value = myTable(i, 2)
    oTable.Rows.Item(i).Item(3).Value = myTable(i, 3)
    oTable.Rows.Item(i).Item(4).Value = myTable(i, 4)
    oTable.Rows.Item(i).Item(5).Value = myTable(i, 5)
    oTable.Rows(i).Height = 0.35
Next i

GoTo 2
1:
On Error Resume Next

MsgBox "Makro has been cancelled! Maybe the standard model for this drawing is no Pipe? There has to be a view of a pipe on the sheet!", vbCritical, "Piping Makro"
2:
End Sub