Strange, lot of good stuff there. but not httpS. Some browsers don't like that. Anyway, I have an improved version.
It generates lots of things that you did not ask for. And among other settings, you can turn them off. Have a look at the settings on line 11 to 14 and 31 to 37.
Public Class ThisRule
Private _doc As DrawingDocument
Private _sheet As Sheet
Private _view As DrawingView
Private _intents As List(Of GeometryIntent) = New List(Of GeometryIntent)()
Private _threadDrawingCurves As List(Of DrawingCurve) = New List(Of DrawingCurve)()
Private _centerPointIntents As List(Of GeometryIntent) = New List(Of GeometryIntent)()
' Some settings here for you to change.
Private _countSameDimensions = True
Private _stackedDimensions As Boolean = False
Private _firstOffset As Double = 1.2 'Cm
Private _offsetDimension As Double = 0.8 'Cm
Public Sub Main()
_doc = ThisDoc.Document
_sheet = _doc.ActiveSheet
_view = ThisApplication.CommandManager.Pick(
SelectionFilterEnum.kDrawingViewFilter,
"Select a drawing view")
If (_view Is Nothing) Then
MsgBox("Nothing was selected.")
return
End If
Dim transaction As Transaction = ThisApplication.TransactionManager.StartTransaction(_doc, "Generate dimensions")
CreateIntentList()
' Comment out features that you dont want/need!
CreateHorizontalDimensions()
CreateVerticalDimensions()
CreateMarks()
AddDiameterDimensionToCircles()
AddThreadNotes()
CreateHorizontalOuterDimension()
CreateVerticalOuterDimension()
transaction.End()
End Sub
Public Sub CreateHorizontalDimensions()
Dim orderedIntents = _intents.OrderBy(Function(s) s.PointOnSheet.X)
Dim orderedCenterIntents = _centerPointIntents.OrderBy(Function(s) s.PointOnSheet.X)
Dim pointLeft = orderedIntents.First
Dim pointRight = Nothing
Dim lastX = pointLeft.PointOnSheet.X
Dim offset As Double = _firstOffset
For Each intent As GeometryIntent In orderedCenterIntents
pointRight = intent
If (AreEqual(pointRight.PointOnSheet.X, lastX)) Then
Continue For
End If
CreateHorizontalDimension(pointLeft, pointRight, offset)
If _stackedDimensions Then
offset = offset + _offsetDimension
Else
pointLeft = pointRight
End If
lastX = pointRight.PointOnSheet.X
Next
pointRight = orderedIntents.Last
CreateHorizontalDimension(pointLeft, pointRight, offset)
End Sub
Private Sub CreateHorizontalDimension(pointLeft As GeometryIntent,
pointRight As GeometryIntent,
distanceFromView As Double)
Dim textX = pointLeft.PointOnSheet.X +
(pointRight.PointOnSheet.X - pointLeft.PointOnSheet.X) / 2
Dim textY = _view.Position.Y + _view.Height / 2 + distanceFromView
Dim pointText = ThisApplication.TransientGeometry.CreatePoint2d(textX, textY)
_sheet.DrawingDimensions.GeneralDimensions.AddLinear(
pointText, pointLeft, pointRight, DimensionTypeEnum.kHorizontalDimensionType)
End Sub
Private Sub CreateHorizontalOuterDimension()
Dim orderedIntents = _intents.OrderByDescending(Function(s) s.PointOnSheet.X)
Dim pointLeft = orderedIntents.First
Dim pointRight = orderedIntents.Last
CreateHorizontalDimension(pointLeft, pointRight, _firstOffset + _offsetDimension)
End Sub
Public Sub CreateVerticalDimensions()
Dim orderedIntents = _intents.OrderByDescending(Function(s) s.PointOnSheet.Y)
Dim orderedCenterIntents = _centerPointIntents.OrderByDescending(Function(s) s.PointOnSheet.Y)
Dim pointLeft = orderedIntents.First
Dim pointRight = Nothing
Dim lastY = pointLeft.PointOnSheet.Y
Dim offset As Double = _firstOffset
For Each intent As GeometryIntent In orderedCenterIntents
pointRight = intent
If (AreEqual(pointRight.PointOnSheet.Y, lastY)) Then
Continue For
End If
CreateVerticalDimension(pointLeft, pointRight, offset)
If _stackedDimensions Then
offset = offset + _offsetDimension
Else
pointLeft = pointRight
End If
lastY = pointRight.PointOnSheet.Y
Next
pointRight = orderedIntents.Last
CreateVerticalDimension(pointLeft, pointRight, offset)
End Sub
Private Sub CreateMarks()
Dim done As List(Of GeometryIntent) = New List(Of GeometryIntent)()
Dim orderedCenterIntents = _centerPointIntents.OrderByDescending(Function(s) s.PointOnSheet.Y)
Dim firstIntent = orderedCenterIntents(0)
Dim secondIntent = Nothing
For i = 1 To orderedCenterIntents.Count - 1
secondIntent = orderedCenterIntents(i)
If (AreEqual(firstIntent.PointOnSheet.Y, secondIntent.PointOnSheet.Y)) Then
CreateCenterLine(firstIntent, secondIntent)
done.Add(firstIntent)
done.Add(secondIntent)
End If
firstIntent = secondIntent
Next
orderedCenterIntents = _centerPointIntents.OrderByDescending(Function(s) s.PointOnSheet.X)
firstIntent = orderedCenterIntents(0)
secondIntent = Nothing
For i = 1 To orderedCenterIntents.Count - 1
secondIntent = orderedCenterIntents(i)
If (AreEqual(firstIntent.PointOnSheet.X, secondIntent.PointOnSheet.X)) Then
CreateCenterLine(firstIntent, secondIntent)
done.Add(firstIntent)
done.Add(secondIntent)
End If
firstIntent = secondIntent
Next
For Each intent As GeometryIntent In orderedCenterIntents
If (done.Contains(intent)) Then
Continue For
End If
_sheet.Centermarks.Add(intent)
Next
End Sub
Public Sub CreateCenterLine(pointLeft As GeometryIntent, pointRight As GeometryIntent)
Dim collection = ThisApplication.TransientObjects.CreateObjectCollection()
collection.Add(pointLeft)
collection.Add(pointRight)
_sheet.Centerlines.Add(collection)
End Sub
Private Sub CreateVerticalDimension(pointLeft As GeometryIntent,
pointRight As GeometryIntent,
distanceFromView As Double)
Dim textY = pointLeft.PointOnSheet.Y +
(pointRight.PointOnSheet.Y - pointLeft.PointOnSheet.Y) / 2
Dim textX = _view.Position.X - _view.Width / 2 - distanceFromView
Dim pointText = ThisApplication.TransientGeometry.CreatePoint2d(textX, textY)
_sheet.DrawingDimensions.GeneralDimensions.AddLinear(
pointText, pointLeft, pointRight, DimensionTypeEnum.kVerticalDimensionType)
End Sub
Private Sub CreateVerticalOuterDimension()
Dim orderedIntents = _intents.OrderByDescending(Function(s) s.PointOnSheet.Y)
Dim pointLeft = orderedIntents.Last
Dim pointRight = orderedIntents.First
CreateVerticalDimension(pointLeft, pointRight, _firstOffset + _offsetDimension)
End Sub
Private Sub AddIntent(Geometry As DrawingCurve, IntentPlace As Object, onLineCheck As Boolean)
Dim intent As GeometryIntent = _sheet.CreateGeometryIntent(Geometry, IntentPlace)
If intent.PointOnSheet Is Nothing Then Return
If onLineCheck Then
If (IntentIsOnCurve(intent)) Then
_intents.Add(intent)
End If
Else
_intents.Add(intent)
End If
End Sub
Private Function IntentIsOnCurve(intent As GeometryIntent) As Boolean
Dim Geometry As DrawingCurve = intent.Geometry
Dim sp = intent.PointOnSheet
Dim pts(1) As Double
Dim gp() As Double = {}
Dim md() As Double = {}
Dim pm() As Double = {}
Dim st() As SolutionNatureEnum = {}
pts(0) = sp.X
pts(1) = sp.Y
Try
Geometry.Evaluator2D.GetParamAtPoint(pts, gp, md, pm, st)
Catch ex As Exception
Return False
End Try
Return True
End Function
Private Sub CreateIntentList()
For Each drawingCurve As DrawingCurve In _view.DrawingCurves
If (DrawingCurve.EdgeType = DrawingEdgeTypeEnum.kThreadEdge) Then
_threadDrawingCurves.Add(DrawingCurve)
End If
Select Case DrawingCurve.ProjectedCurveType
Case _
Curve2dTypeEnum.kCircleCurve2d,
Curve2dTypeEnum.kCircularArcCurve2d,
Curve2dTypeEnum.kEllipseFullCurve2d,
Curve2dTypeEnum.kEllipticalArcCurve2d
AddIntent(DrawingCurve, PointIntentEnum.kCircularTopPointIntent, True)
AddIntent(DrawingCurve, PointIntentEnum.kCircularBottomPointIntent, True)
AddIntent(DrawingCurve, PointIntentEnum.kCircularLeftPointIntent, True)
AddIntent(DrawingCurve, PointIntentEnum.kCircularRightPointIntent, True)
AddIntent(DrawingCurve, PointIntentEnum.kEndPointIntent, False)
AddIntent(DrawingCurve, PointIntentEnum.kStartPointIntent, False)
If (DrawingCurve.ProjectedCurveType = Curve2dTypeEnum.kCircleCurve2d) Then
Dim intent = _sheet.CreateGeometryIntent(DrawingCurve, PointIntentEnum.kCenterPointIntent)
_centerPointIntents.Add(intent)
End If
Case _
Curve2dTypeEnum.kLineCurve2d,
Curve2dTypeEnum.kLineSegmentCurve2d
AddIntent(DrawingCurve, PointIntentEnum.kEndPointIntent, False)
AddIntent(DrawingCurve, PointIntentEnum.kStartPointIntent, False)
Case _
Curve2dTypeEnum.kPolylineCurve2d,
Curve2dTypeEnum.kBSplineCurve2d,
Curve2dTypeEnum.kUnknownCurve2d
' Unhandled curves types
Case Else
End Select
Next
End Sub
Private Sub AddDiameterDimensionToCircles()
Dim doneCurves As New List(Of DrawingCurve)()
Dim doneDims As New List(Of DoneDiameter)()
For Each intent As GeometryIntent In _intents
Dim geo = intent.Geometry
If (geo.type <> ObjectTypeEnum.kDrawingCurveObject) Then
Continue For
End If
Dim curve As DrawingCurve = geo
If (doneCurves.Contains(curve)) Then Continue For
doneCurves.Add(curve)
If (curve.ProjectedCurveType <> Curve2dTypeEnum.kCircleCurve2d) Then
Continue For
End If
Dim rangeBox = curve.Evaluator2D.RangeBox
Dim radius = (rangeBox.MaxPoint.X - rangeBox.MinPoint.X) / 2
Dim doneDim = doneDims.FirstOrDefault(Function(d) d.Radius = radius)
If (doneDim Is Nothing Or Not _countSameDimensions) Then
Dim x = curve.CenterPoint.X + radius
Dim y = curve.CenterPoint.Y + radius
Dim textPoint = ThisApplication.TransientGeometry.CreatePoint2d(x, y)
Dim dimension = _sheet.DrawingDimensions.GeneralDimensions.AddDiameter(textPoint, intent)
Dim d As New DoneDiameter()
d.Dimension = dimension
d.Radius = radius
doneDims.Add(d)
Else
doneDim.Count += 1
End If
Next
For Each doneDim As DoneDiameter In doneDims
If (doneDim.Count = 1) Then Continue For
Dim txt = String.Format("<DimensionValue/> ({0}x)", doneDim.Count)
doneDim.Dimension.Text.FormattedText = txt
Next
End Sub
Private Sub AddThreadNotes()
Dim notes = _sheet.DrawingNotes.HoleThreadNotes
For Each curve As DrawingCurve In _threadDrawingCurves
Dim rangeBox = curve.Evaluator2D.RangeBox
Dim radius = (rangeBox.MaxPoint.X - rangeBox.MinPoint.X) / 2
Dim x = curve.CenterPoint.X - radius * 5
Dim y = curve.CenterPoint.Y - radius * 5
Dim textPoint = ThisApplication.TransientGeometry.CreatePoint2d(x, y)
notes.Add(textPoint, curve)
Next
End Sub
Private Class DoneDiameter
Public Property Dimension As DiameterGeneralDimension
Public Property Count As Integer = 1
Public Property Radius As Double
End Class
Private Function AreEqual(d1 As Double, d2 As Double)
Return (Math.Abs(d1 - d2) < 0.000001)
End Function
' This code was written by Jelte de Jong, and published on www.hjalte.nl
End Class
Jelte de Jong
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.
Blog: hjalte.nl - github.com
