Gleiche Flächen finden

Option Explicit

Sub main()
    Dim swApp As SldWorks.SldWorks: Set swApp = Application.SldWorks
    Dim swModel As ModelDoc2: Set swModel = swApp.ActiveDoc
    If swModel Is Nothing Then Exit Sub
    Dim swSelMgr As SelectionMgr: Set swSelMgr = swModel.SelectionManager
    If swSelMgr.GetSelectedObjectCount2(-1) <> 1 Then Exit Sub
    If swSelMgr.GetSelectedObjectType3(1, -1) = swSelectType_e.swSelFACES Then HandleFaces swSelMgr
    
End Sub

Private Sub HandleFaces(ByRef selMgr As SelectionMgr)
    'Ausgewählte Fläche erhalten
    Dim swFace As Face2: Set swFace = selMgr.GetSelectedObject6(1, -1)
    Dim swSurface As Surface: Set swSurface = swFace.GetSurface
    If swSurface.IsPlane = False Then Exit Sub
    'Infos aus der Fläche auslesen
    Dim faceNormal As Variant: faceNormal = swFace.Normal
    Debug.Print faceNormal(0)
    Debug.Print faceNormal(1)
    Debug.Print faceNormal(2)
    'Andere Flächen finden mit der selben Ausrichtung
    Dim swBody As Body2: Set swBody = swFace.GetBody
    Dim bodyFaces As Variant: bodyFaces = swBody.GetFaces
    Dim vFace As Variant
    For Each vFace In bodyFaces
        Dim tFace As Face2: Set tFace = vFace
        Dim tFaceNormal As Variant: tFaceNormal = tFace.Normal
        If Round(Abs(tFaceNormal(0)), 8) = Round(Abs(faceNormal(0)), 8) And _
           Round(Abs(tFaceNormal(1)), 8) = Round(Abs(faceNormal(1)), 8) And _
           Round(Abs(tFaceNormal(2)), 8) = Round(Abs(faceNormal(2)), 8) Then
            Dim swEntity As Entity: Set swEntity = tFace
            swEntity.Select4 True, Nothing
        End If
    Next
End Sub