Code:
Sub EbenenParallel()Dim oSS As SelectSet
Dim oFace1 As FaceProxy
Dim oFace2 As FaceProxy
Dim oPlane1 As Plane
Dim oPlane2 As Plane
'Wenn zwei planare Flächen gewählt sind, dann extrahiere die PLANE Objekte, sonst Fehlermeldung
Set oSS = ThisApplication.ActiveDocument.SelectSet
If oSS.Count <> 2 Then
MsgBox "Bitte zwei Flächen markieren."
Exit Sub
End If
If (oSS(1).Type <> kFaceProxyObject) Or (oSS(2).Type <> kFaceProxyObject) Then
MsgBox "Bitte zwei Flächen markieren (evtl. Auswahlmodus auf 'Fläche' setzen)."
Exit Sub
End If
Set oFace1 = ThisApplication.ActiveDocument.SelectSet.Item(1)
Set oFace2 = ThisApplication.ActiveDocument.SelectSet.Item(2)
If (oFace1.SurfaceType <> kPlaneSurface) Or (oFace2.SurfaceType <> kPlaneSurface) Then
MsgBox "Bitte zwei ebene Flächen markieren."
Exit Sub
End If
Set oPlane1 = oFace1.Surface(kPlaneSurface)
Set oPlane2 = oFace2.Surface(kPlaneSurface)
'Die PlaneObjekte sind parallel, wenn der Winkel Phi zwischen den Normalen 0° oder 180° ist, d.h. Cos Phi = 1 oder -1
'
' Cos Phi = ab/|a|*|b| - wobei |a| und |b| = 1 sind, da ja "Normale"
Dim cphi As Double
cphi = oPlane1.Normal.x * oPlane2.Normal.x + oPlane1.Normal.y * oPlane2.Normal.y + oPlane1.Normal.Z * oPlane2.Normal.Z
Debug.Print Str(cphi)
'Prüfe auf 1 oder -1 mit Toleranz
If (1 - Abs(cphi)) < 0.00000001 Then
MsgBox "Flächen sind parallel"
Else
MsgBox "Flächen sind nicht parallel"
End If
End Sub