---

Hi,

irgendwo klemmts heut mal bei mir bei der Erstellung von Schnitten.

Ich möchte Elemente auswählen und mit diesen Elementen Schnitte erstellen.
Betonung liegt auf Mehrzahl von Element (nicht nur eines) 

Ein Element schneiden funktioniert so einigermaßen... (Besser wie nix vom Ergebnbis betrachtet Da die verdeckten Linien nicht separat gestrichelt werden können hat das mit Normgerecht wenig zu tun.)

Anyway - das Schnittobjekt wird erstellt, auch eingestellt, nur wenn ich den Schnitt dann erzeugen will dann macht er nur ein Objekt.
Egal was man an .GenerateSectionGeometry übergibt. (Variants mag das garnicht dann stürtzt der Kram ab)
Entweder hab ich das falsche API oder das USA Raffel kann wieder seit Jahren nix  )

Flatshot zu automatisieren ohne am Dialog mit Windows messages rumzuhacken scheint auch nicht zu gehen.

Falls da noch wer ne Idee dazu hatte würd es mich freuen 

Liebe Grüße
Thomas

CODE under construction: (schön ist anders)
Sub GenSection33()

Dim entity As AcadEntity

Dim ENTITYS() As AcadEntity
Dim count As Long

For Each entity In ThisDrawing.modelspace
If InStr(LCase(entity.ObjectName), "sol") > 0 Then count = count + 1
Next

count = count - 1

Debug.Print count
ReDim ENTITYS(0 To count)
    Dim counter As Long
   
   
    For Each entity In ThisDrawing.modelspace
    If InStr(LCase(entity.ObjectName), "solid") > 0 Then Set ENTITYS(counter) = entity
    counter = counter + 1
    Next

Dim x3DSolid As Acad3DSolid
'ThisDrawing.Utility.GetEntity x3DSolid, basePt, "Pick 3D Solid"

Dim planeVector(0 To 2) As Double
planeVector(0) = 0: planeVector(1) = 0: planeVector(2) = 1
PT1 = ThisDrawing.Utility.GetPoint(, "Pick first point")
PT2 = ThisDrawing.Utility.GetPoint(, "Pick end point")
h = CDbl(1)

PT1(2) = -555

PT2(2) = -555

Dim sec As ACADOBJECT
Dim sec2 As ACADOBJECT
Dim ttt As ACADOBJECT

Dim ss As AcadSectionSettings
Dim ss2 As AcadSectionSettings
Dim tttss As AcadSectionSettings

On Error Resume Next
'Set sec = ThisDrawing.modelspace.AddSection(PT1, PT2, planeVector)
'Set sec2 = ThisDrawing.modelspace.AddSection(PT1, PT2, planeVector)
Set ttt = ThisDrawing.modelspace.AddSection(PT1, PT2, planeVector)

Dim fg As AcadSection
'fg.state = acSectionStateVolume
'acSectionStateVolume
'acSectionStatePlane
'acSectionStateBoundary

'fg.State2=
'acSectionState2Volume
'acSectionState2Slice
'acSectionState2Plane
'acSectionState2Boundary

On Error GoTo 0
With ttt

Set tttss = ttt.Settings

.state = acSectionStateBoundary

'acSectionStateVolume
'acSectionStatePlane
'acSectionStateBoundary

'.State2 = 4
'acSectionState2Boundary
'acSectionState2Volume
'acSectionState2Slice
'acSectionState2Plane
'acSectionState2Boundary

If ttt.state <> acSectionState2Plane Then
'tttss.SectionPlaneOffset = 10#
End If
.BottomHeight = 0.1
.TopHeight = 5555
.Color = acRed
'.VerticalDirection = 1
'.ViewingDirection = 1
tttss.CurrentSectionType = acSectionType2dSection
End With

Dim acSectionTypeSettings3 As AcadSectionTypeSettings

Set acSectionTypeSettings3 = tttss.GetSectionTypeSettings(acSectionType2dSection)
Dim col As New AcadAcCmColor
col.SetRGB 255, 0, 255

With acSectionTypeSettings3
Dim VE
VE = ENTITYS

.GenerationOptions = acSectionGenerationSourceSelectedObjects + 16

.SourceObjects = VE

On Error Resume Next

Call layer_clone("HIDDEN", "0")
Call layer_clone("FORE", "0")
Call layer_clone("INTER", "0")
Call layer_clone("BOUND", "0")
Call layer_clone("COURVE", "0")
Call layer_clone("HATCH", "0")
 
.ForegroundLinesLayer = "FORE"
.ForegroundLinesLinetype = "continue"
.ForegroundLinesLinetypeScale = 1
.ForegroundLinesLineweight = acLnWt035
.ForegroundLinesPlotStyleName = "ByColor"
col.SetRGB 0, 255, 255: .ForegroundLinesColor = col

.BackgroundLinesLayer = "HIDDEN"
.BackgroundLinesLinetype = "DASHED"
.BackgroundLinesLinetypeScale = 1
.BackgroundLinesLineweight = acLnWt025
.BackgroundLinesPlotStyleName = "ByColor"
col.SetRGB 255, 255, 0: .BackgroundLinesColor = col

.CurveTangencyLinesLayer = "COURVE"
.CurveTangencyLinesLinetype = "continue"
.CurveTangencyLinesLinetypeScale = 1
.CurveTangencyLinesLineweight = acLnWt013
.CurveTangencyLinesPlotStyleName = "ByColor"
col.SetRGB 255, 0, 0: .CurveTangencyLinesColor = col

.IntersectionLinesLayer = "INTER"
.IntersectionLinesLinetype = "continue"
.IntersectionLinesLinetypeScale = 1
.IntersectionLinesLineweight = acLnWt050
col.SetRGB 0, 55, 255: .IntersectionLinesColor = col
.IntersectionLinesPlotStyleName = "ByColor"

col.SetRGB 255, 155, 155: .IntersectionBoundaryColor = col

.IntersectionBoundaryLayer = "BOUND"
.IntersectionBoundaryLinetype = "continue"
.IntersectionBoundaryLinetypeScale = 1
.IntersectionBoundaryLineweight = acLnWt013
.IntersectionBoundaryPlotStyleName = "ByColor"

col.SetRGB 0, 255, 0: .IntersectionFillColor = col
.IntersectionFillFaceTransparency = 10
.IntersectionFillHatchAngle = 0
.IntersectionFillHatchPatternType = acHatchPatternTypePreDefined
.IntersectionFillHatchPatternName = "Solid"
.IntersectionFillHatchScale = 1
.IntersectionFillHatchSpacing = 1
.IntersectionFillLayer = "HATCH"

   

.ForegroundLinesVisible = True
.ForegroundLinesFaceTransparency = True
.ForegroundLinesHiddenLine = True

.BackgroundLinesHiddenLine = True
.BackgroundLinesVisible = True

.IntersectionLinesHiddenLine = True
.IntersectionLinesVisible = True

.IntersectionBoundaryVisible = True
.intersectionboundaryHiddenLine = True

.CurveTangencyLinesVisible = True
.curvetangencyLinesHiddenLine = True

End With
On Error GoTo 0
ttt.GenerateSectionGeometry ENTITYS(0), BoundaryObjs, FillObjs, BakcGroundObjs, ForegroundObjs, CurveTangencyObjs

End Sub

------------------
Wer es nicht versucht, hat schon verlorn 
Und bei 3 Typos gibts den vierten gratis !
<<< for sale !

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP