Generating sections
Accepted solution
I've never used vba to generate a section before (I don't use acad for 3D), but a search doesn't turn up any code samples. It looks like the vba api for sections is not very useful. That said, there is no setSectionTypeSettings method. Is that something you created? You may need to show all your code. Make sure to put in in a code window using the </> button.
Ed
Did you find this post helpful? Feel free to Like this post.
Did your question get successfully answered? Then click on the ACCEPT SOLUTION button.
How to post your code.
Accepted solution
I'm really busy right now, but if you post a sample 3D dwg, I'll take a look.
Ed
Did you find this post helpful? Feel free to Like this post.
Did your question get successfully answered? Then click on the ACCEPT SOLUTION button.
How to post your code.
Accepted solution
I edited your code somewhat. Your use of On Error Resume Next was masking the real errors. There are still a few I don't have time to figure out, but it has to do with the section object and its properties. You need to figure out that part to get the results you want. The edited code is below. However, I was able to create this with the VIEWBASE command and right clicking the resulting view and selecting Create Veiw>Section View. It only took a few seconds. So I'm not sure you need to code this. I've attached an updated dwg so you can see the results.
Public Sub CreateSectionViewsFrom3DSolid()
On Error GoTo Err_Control
Dim oAcadSec As AcadSection
Dim SectionSettings As AcadSectionSettings
Dim setSectionTypeSettings As AcadSectionTypeSettings
Dim dPlaneVector(0 To 2) As Double
Dim x3DSolid As Acad3DSolid
Dim vBasePt As Variant
Dim vPt1 As Variant
Dim vPt2 As Variant
' Get the solid
' You need to trap for when the user doesn't select a solid.
GetSolid:
ThisDrawing.Utility.GetEntity x3DSolid, vBasePt, "Pick 3D Solid"
' If nothing was selected, the error number will be -2147352567
' The error handler catches that. My default is to exit the sub,
' but you can change the GoTo to point to GetSolid and it will
' prompt the user again until they select a solid or hit {ESC}.
' get 2 section points
vPt1 = ThisDrawing.Utility.GetPoint(, "Pick first point")
' If you supply vPt1 as the first arg, it will draw a line between the two.
vPt2 = ThisDrawing.Utility.GetPoint(vPt1, "Pick end point")
' The below vector [0,0,1] will give a vertical section through a solid
dPlaneVector(0) = 0: dPlaneVector(1) = 0: dPlaneVector(2) = 1
'------------------------------------------------------------------------------
' Insert Section object
'------------------------------------------------------------------------------
' Create the section object
Set oAcadSec = ThisDrawing.ModelSpace.AddSection(vPt1, vPt2, dPlaneVector)
'newly created section is parallel to solid and doesn't intersect with it.
With oAcadSec
.Elevation = 350
.State = acSectionStatePlane
.State2 = acSectionState2Slice
.SliceDepth = 250#
Set SectionSettings = .Settings
.Update
End With
With SectionSettings
.CurrentSectionType = acSectionType2dSection
End With
Set setSectionTypeSettings = SectionSettings.GetSectionTypeSettings(acSectionType2dSection)
'------------------------------------------------------------------------------
' Section object settings
'------------------------------------------------------------------------------
' Section Settings Background lines
With setSectionTypeSettings
.BackgroundLinesVisible = False
.BackgroundLinesHiddenLine = False
.BackgroundLinesLayer = "PC Bea. Thn" 'Layer doesn't exist
.BackgroundLinesLinetype = "ByLayer"
'.BackgroundLinesColor=""
'.BackgroundLinesLinetypeScale=5
'.BackgroundLinesLineweight=0.18
'.BackgroundLinesPlotStyleName="UPH Monochrome.ctb"
' Section Settings InterSection boundary
' The outline of the Intersection Boundary
' .IntersectionBoundaryVisible = True 'This line generates the "Invalid input" error.
.IntersectionBoundaryLayer = "PC Pnl. Thn" 'Layer doesn't exist
.IntersectionBoundaryLinetype = "ByLayer"
'.IntersectionBoundaryColor=""
'.IntersectionBoundaryDivisionLines = False
'.IntersectionBoundaryLinetypeScale = 5
'.IntersectionBoundaryLineweight = 0.18
'.IntersectionBoundaryPlotStyleName = "UPH Monochrome.ctb"
' Section Settings Intersection fill
' For a face when a section goes through the object
.IntersectionFillVisible = False
'.IntersectionFillColor = "red"
'.IntersectionFillFaceTransparency = [long] [Live Section Only]
'.IntersectionFillHatchAngle=45 [units radian??]
'.IntersectionFillHatchPatternName = "ANSI31"
'.IntersectionFillHatchPatternType = acHatchPatternTypePreDefined
'.IntersectionFillHatchScale = 5
'.IntersectionFillHatchSpacing = 150#
'.IntersectionFillLayer = "PC Htc"
'.IntersectionFillLinetype = "Continous"
'.IntersectionFillLinetypeScale = 5
'.IntersectionFillLineweight = 0.18
'.IntersectionFillPlotStyleName = "UPH Monochrome.ctb"
' Section Settings ForeGround Lines
' This is cut away geometry
.ForegroundLinesVisible = False
.ForegroundLinesHiddenLine = False
'.ForegroundLinesColor=""
'.ForegroundLinesEdgeTransparency = [long] [Live Section Only]
'.ForegroundLinesFaceTransparency= [long] [Live Section Only]
'.ForegroundLinesLayer = "PC Pnl .Thn"
'.ForegroundLinesLinetype = "Continous"
'.ForegroundLinesLinetypeScale = 5
'.ForegroundLinesLineweight = 0.18
'.ForegroundLinesPlotStyleName = "UPH Monochrome.ctb"
' Section Settings CurveTangency Lines
.CurveTangencyLinesVisible = False
'.CurveTangencyLinesColor=""
'.CurveTangencyLinesLayer="PC Pnl
'.CurveTangencyLinesLinetype="Continous"
'.CurveTangencyLinesLinetypeScale=5
'.CurveTangencyLinesLineweight = 0.18
'.CurveTangencyLinesPlotStyleName="UPH Monochrome.ctb"
' Section Settings Others
'.GenerationOptions = acSectionGenerationDestinationNewBlock
'.DestinationBlock = "TestBlock"
'.DestinationFile = "C:\temp\file.dwg"
'.GenerationOptions = acSectionGenerationDestinationFile
'.GenerationOptions = acSectionGenerationDestinationReplaceBlock
'.GenerationOptions = acSectionGenerationSourceAllObjects
'.GenerationOptions = acSectionGenerationSourceSelectedObjects
'.SourceObjects = vObjects
End With
oAcadSec.Update
Dim vBoundaryObjs As Variant
Dim vFillObjs As Variant
Dim vBackGroundObjs As Variant
Dim vForeGroundObjs As Variant
Dim vCurveTangencyObjs As Variant
' This line now generates the invalid input error
' setSectionTypeSettings.GenerationOptions = acSectionGenerationDestinationNewBlock
Dim vBlockGen As Variant ' You didn't declare this var
vBlockGen = setSectionTypeSettings.DestinationBlock
oAcadSec.GenerateSectionGeometry x3DSolid, vBoundaryObjs, vFillObjs, vBackGroundObjs, vForeGroundObjs, vCurveTangencyObjs
oAcadSec.Delete
Exit_Here:
Exit Sub
Err_Control:
Select Case Err.Number
'Add your Case selections here
Case Is = -2147352567
' Nothing was selected.
Err.Clear
Resume Exit_Here
Case Else
MsgBox Err.Number & ", " & Err.Description, , "RotPoly3D"
Err.Clear
Resume Exit_Here
End Select
End Sub
Ed
Did you find this post helpful? Feel free to Like this post.
Did your question get successfully answered? Then click on the ACCEPT SOLUTION button.
How to post your code.
