Code:
Public Function GetDoubleEntTable(entObj As AcadEntity, Pnt As Variant) As String
Dim entHandle As String
entHandle = entObj.Handle
GetDoubleEntTable = "(list(handent " & Chr(34) & entHandle & Chr(34) & ")(list " & Str(Pnt(0)) & Str(Pnt(1)) & Str(Pnt(2)) & "))"
End FunctionPublic Function axPoint2lspPoint(Pnt As Variant) As String
axPoint2lspPoint = Replace(Pnt(0), ",", ".") & "," & Replace(Pnt(1), ",", ".") & "," & Pnt(2)
End Function
'##--Start / Festlegung der Breakpoints---------------------
'FrontPline (FP) ist die zuvor gezeichnete Kontur / Polylinie
'--Variablen für GetBoundingBox der FrontPline--!!!
Dim minFP As Variant
Dim minp(2) As Double
Dim maxFP As Variant
Dim maxp(2) As Double
'--Variablen Allgemein--!!!
Dim Objekt As Object
Dim NewEntity As AcadEntity
'--Grundlagen für den Selectionsset Auswahlsatz 1--!!!
Dim FPSSet As AcadSelectionSet
Set FPSSet = ActiveDocument.SelectionSets.Add("Frontplatte")
If Err <> 0 Then
Set FPSSet = ActiveDocument.SelectionSets("Frontplatte")
End If
Dim LineType(0) As Integer
Dim LineData(0) As Variant
LineType(0) = 0
LineData(0) = "LWPolyline, Polyline"
FrontPline.GetBoundingBox minFP, maxFP
ThisDrawing.Regen acActiveViewport
minp(0) = minFP(0) - 10
minp(1) = minFP(1) - 10
minp(2) = minFP(2)
maxp(0) = maxFP(0) + 10
maxp(1) = maxFP(1) + 10
maxp(2) = maxFP(2)
With FPSSet
.Clear
.Select acSelectionSetCrossing, minp, maxp, LineType, LineData
End With
Dim KappObj As AcadEntity
Dim KappEnt As Variant
Dim KappPkt As String
Dim det As String
Dim SchnittPkt As Variant
Dim BreakPkt(2) As Double
Dim ObjPkt(2) As Double 'dient nur zur Darstellung der Breakpoints
Dim objCircle(2) As AcadCircle 'dient nur zur Darstellung der Breakpoints
On Error Resume Next
For Each KappEnt In FPSSet
Set KappObj = KappEnt
If TypeName(KappObj) = "AcDbPolyline" Or "AcDbLWPolyline" Then
SchnittPkt = KappObj.IntersectWith(FrontPline, acExtendNone)
BreakPkt(0) = SchnittPkt(0)
BreakPkt(1) = SchnittPkt(1)
BreakPkt(2) = SchnittPkt(2)
' KappPkt = Replace(CStr(BreakPkt(0)), ",", ".") & "," & _
' Replace(CStr(BreakPkt(1)), ",", ".") & "," & _
' Replace(CStr(BreakPkt(2)), ",", ".")
'dient nur zur Darstellung der Breakpoints
Set objCircle(2) = ThisDrawing.ModelSpace.AddCircle(BreakPkt, 2)
objCircle(2).Color = acMagenta
det = GetDoubleEntTable(KappObj, KappObj.StartPoint)
KappPkt = axPoint2lspPoint(SchnittPkt)
ThisDrawing.SendCommand "_break" & vbCr & det & vbCr & KappPkt & vbCr
End If
Next KappEnt
FPSSet.Delete
Foren auf CAD.de (alle Foren)
| 
.
