Hallo Colin,
ich habe auf http://hjalte.nl/37-auto-overall-dimension, Code für eine ähnliche Aufgabe gefunden und etwas angepasst. Ich schätze das war was du gesucht hast oder?
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)()
Sub Main()
_doc = ThisDoc.Document
_sheet = _doc.ActiveSheet
_view = ThisApplication.CommandManager.Pick(
SelectionFilterEnum.kDrawingViewFilter,
"Select a drawing view")
' Bohrungsbemaßung erzeugen
CreateIntentList("kCircleCurve2d")
createNormalDiameterDimension()
_intents.Clear()
' Gewindebemaßung erzeugen
CreateIntentList("kCircularArcCurve2d")
createThreadDimension()
End Sub
Private Sub createNormalDiameterDimension()
For Each intent In _intents
Dim radius As Double = intent.Geometry.ModelGeometry.Geometry.Radius
If radius = 0.4 Then
Dim textY = intent.PointOnSheet.Y
Dim textX = intent.Geometry.Evaluator2D.RangeBox.MinPoint.X - 2*radius
Dim pointText = ThisApplication.TransientGeometry.CreatePoint2d(textX, textY)
Dim diameter As DiameterGeneralDimension = _sheet.DrawingDimensions.GeneralDimensions.AddDiameter(pointText, intent, , True, False)
diameter.Tolerance.SetToFits(kLimitsFitsStackedTolerance,"H8","")
End If
Next
End Sub
Private Sub createThreadDimension()
Dim intent_count As Integer = 1
For Each intent In _intents
If (intent_count Mod 2) > 0 Then
Dim pointLeft = intent
Dim pointRight = _intents(intent_count)
Dim textY = pointLeft.PointOnSheet.Y + (pointRight.PointOnSheet.Y - pointLeft.PointOnSheet.Y) / 2
Dim textX = pointLeft.PointOnSheet.X + (pointLeft.PointOnSheet.Y - pointRight.PointOnSheet.Y)
Dim pointText = ThisApplication.TransientGeometry.CreatePoint2d(textX, textY)
Dim thread As LinearGeneralDimension = _sheet.DrawingDimensions.GeneralDimensions.AddLinear(pointText, pointLeft, pointRight, DimensionTypeEnum.kVerticalDimensionType)
thread.Text.FormattedText = "M<DimensionValue/>"
intent_count +=1
Else
intent_count +=1
Continue For
End If
Next
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(Intentfilter As String)
Select Case Intentfilter
Case "kCircleCurve2d"
For Each oDrawingCurve As DrawingCurve In _view.DrawingCurves
If oDrawingCurve.ProjectedCurveType = Curve2dTypeEnum.kCircleCurve2d Then
addIntent(oDrawingCurve, PointIntentEnum.kCircularLeftPointIntent, True)
End If
Next
Case "kCircularArcCurve2d"
For Each oDrawingCurve As DrawingCurve In _view.DrawingCurves
If oDrawingCurve.ProjectedCurveType = Curve2dTypeEnum.kCircularArcCurve2d Then
addIntent(oDrawingCurve, PointIntentEnum.kCircularBottomPointIntent, True)
addIntent(oDrawingCurve, PointIntentEnum.kCircularTopPointIntent, True)
End If
Next
End Select
End Sub
End Class
Das einzige "Problem", wo auch der Autor drauf hinweist, ist das die Bemaßungen bei jedem ausführen nochmal erstellt werden und dann übereinander liegen.
Grüße
