Steve, I ended up with the following code that I am happy with and it addresses our needs. Works well in both 2023 and 2025. Maybe you can use it (or parts of it):
Public Class ThisRule
Sub Main()
oDoc = ThisDoc.Document
oNamer = "Highlight Dimension Overrides"
Dim UNDO As Transaction
UNDO = ThisApplication.TransactionManager.StartTransaction(oDoc, oNamer)
'---- Undo Wrapper
If ThisApplication.ActiveDocument.DocumentType = kPartDocumentObject Then 'OK, run his
Dim markStyleName = "Mark Surface"
Dim markText = iProperties.Value("Project", "Part Number")
Dim textHeight = 3 'Cm
If (String.IsNullOrWhiteSpace(markText)) Then
MsgBox("Part Number property not set. Part not saved yet?",, "No mark text")
Return
End If
Dim selector As New Selector(ThisApplication)
selector.Pick()
If (selector.SelectedObject Is Nothing) Then Return
Dim face As Face = selector.SelectedObject
Dim pointOnFace As Point = selector.ModelPosition
CreateMarkFeatur(face, pointOnFace, markStyleName, markText, textHeight)
Else
MessageBox.Show("Please use on part document. Inplace edit not yet supported")
End If
' Undo Wrapper -------------------------------------------------------------------------------------
UNDO.End
End Sub
Private Sub CreateMarkFeatur(face As Face, pointOnFace As Point, markStyleName As String, markText As String, textHeight As Double)
Dim doc As PartDocument = ThisDoc.Document
Dim def As PartComponentDefinition = doc.ComponentDefinition
'messagebox.Show("about to crash if edit in assembly")
Dim sketch = def.Sketches.Add(face)
Dim modelPoint As Point2d = sketch.ModelToSketchSpace(pointOnFace)
sText = "<Property Document='model' FormatID='{32853F0F-3444-11d1-9E93-0060B03C1CA6}' PropertyID='5' /> " 'Using actual property, not value
Dim formatedText = String.Format("<StyleOverride FontSize='{0}'>{1}</StyleOverride>", textHeight, sText)
Dim sketchText = sketch.TextBoxes.AddFitted(modelPoint, formatedText)
sketchText.Height = 4
sketchText.Width = 50
sketchText.Style.HorizontalJustification = 19969 ' Text centered about the supplied point.
sketchText.Style.VerticalJustification = 25601
sketchText.ShowBoundaries() = True
'--------------- add dims To Text box---------------------
Dim oInvApp As Inventor.Application = ThisApplication
Dim oTG As TransientGeometry = oInvApp.TransientGeometry
Dim oPDoc As PartDocument = oInvApp.ActiveDocument
Dim oPDef As PartComponentDefinition = oPDoc.ComponentDefinition
Dim oUsParams As UserParameters = oPDef.Parameters.UserParameters
Dim oSketch As PlanarSketch = oPDef.Sketches(1)
Dim oText = sketchText 'As Inventor.TextBox = oSketch.TextBoxes(1)
Dim oDimH, oDimW As TwoPointDistanceDimConstraint
For Each oLine As SketchLine In oText.BoundaryGeometry
Dim oS As Point2d = oLine.Geometry.StartPoint
Dim oM As Point2d = oLine.Geometry.MidPoint
Dim oE As Point2d = oLine.Geometry.EndPoint
If oS.X = oE.X And oDimH Is Nothing Then
Dim oPText As Point2d
oPText = oTG.CreatePoint2d(oS.X - 1, oM.Y)
oDimH = oSketch.DimensionConstraints.AddTwoPointDistance(oLine.StartSketchPoint,
oLine.EndSketchPoint,
DimensionOrientationEnum.kVerticalDim,
oPText,
False)
' oDimH.Parameter.Expression = oUsParams("d_H").Name
Else If oS.Y = oE.Y And oDimW Is Nothing Then
Dim oPText As Point2d
oPText = oTG.CreatePoint2d(oM.X, oS.Y+1)
oDimW = oSketch.DimensionConstraints.AddTwoPointDistance(oLine.StartSketchPoint,
oLine.EndSketchPoint,
DimensionOrientationEnum.kHorizontalDim,
oPText,
False)
' oDimW.Parameter.Expression = oUsParams("d_W").Name
End If
Next
'-------dim text box end -------------------------
Dim markGeometry As ObjectCollection = ThisApplication.TransientObjects.CreateObjectCollection()
markGeometry.Add(sketchText)
Dim markFeatures As MarkFeatures = def.Features.MarkFeatures
Dim markStyle As MarkStyle = doc.MarkStyles.Item(markStyleName)
Dim markDef As MarkDefinition = markFeatures.CreateMarkDefinition(markGeometry, markStyle)
If (ThisApplication.SoftwareVersion.Major >= 28) Then
' The following property was introduced in Inventor 2024
' Therefore we can't set this property before Inventor 2024
' If this is not set after Inventor 2023 the rule fails most of the time.
' (Major version 28 = Inventor 2024)
markDef.Direction = PartFeatureExtentDirectionEnum.kNegativeExtentDirection
End If
markFeatures.Add(markDef)
'-----------------------Renaming feature name tp "PN".
'First Get the last feature
Dim lastFeature As PartFeature
lastFeature = ThisDoc.Document.ComponentDefinition.Features.Item(ThisDoc.Document.ComponentDefinition.Features.Count)
'MessageBox.Show(lastFeature.Name)
' Define the base new feature name
Dim baseFeatureName As String
baseFeatureName = "PN"
' Initialize the new feature name with the base name
Dim newFeatureName As String
newFeatureName = baseFeatureName
' Check if the new feature name already exists and add a number if needed
Dim counter As Integer
counter = 2
While FeatureNameExists(newFeatureName)
newFeatureName = baseFeatureName & counter.ToString()
counter += 1
End While
' Rename the last feature
On Error Resume Next
lastFeature.Name = newFeatureName
'If Err.Number <> 0 Then
' MessageBox.Show("Failed to rename the feature. The name might already be in use.", "Error")
' Err.Clear()
'Else
' MessageBox.Show("The last feature has been renamed to " & newFeatureName, "Success")
'End If
'--------------------
sketch.Edit
End Sub
' Function to check if a feature name already exists
Function FeatureNameExists(featureName As String) As Boolean
Dim feat As PartFeature
For Each feat In ThisDoc.Document.ComponentDefinition.Features
If feat.Name.ToUpper() = featureName Then
Return True
End If
Next
Return False
End Function
End Class
Public Class Selector
Private WithEvents _interactEvents As InteractionEvents
Private WithEvents _selectEvents As SelectEvents
Private _stillSelecting As Boolean
Private _inventor As Inventor.Application
Public Sub New(ThisApplication As Inventor.Application)
_inventor = ThisApplication
End Sub
Public Sub Pick()
_stillSelecting = True
_interactEvents = _inventor.CommandManager.CreateInteractionEvents
_interactEvents.InteractionDisabled = False
_interactEvents.StatusBarText = "Select a point on a face."
_selectEvents = _interactEvents.SelectEvents
_selectEvents.WindowSelectEnabled = False
_interactEvents.Start()
Do While _stillSelecting
_inventor.UserInterfaceManager.DoEvents()
Loop
_interactEvents.Stop()
_inventor.CommandManager.StopActiveCommand()
End Sub
Public Property SelectedObject As Face = Nothing
Public Property ModelPosition As Point = Nothing
Private Sub oSelectEvents_OnPreSelect(
ByRef PreSelectEntity As Object,
ByRef DoHighlight As Boolean,
ByRef MorePreSelectEntities As ObjectCollection,
SelectionDevice As SelectionDeviceEnum,
ModelPosition As Point,
ViewPosition As Point2d,
View As Inventor.View) Handles _selectEvents.OnPreSelect
DoHighlight = False
If TypeOf PreSelectEntity Is Face Then
If TypeOf PreSelectEntity.Geometry Is Plane Then
DoHighlight = True
End If
End If
End Sub
Private Sub oInteractEvents_OnTerminate() Handles _interactEvents.OnTerminate
_stillSelecting = False
End Sub
Private Sub oSelectEvents_OnSelect(
ByVal JustSelectedEntities As ObjectsEnumerator,
ByVal SelectionDevice As SelectionDeviceEnum,
ByVal ModelPosition As Point,
ByVal ViewPosition As Point2d,
ByVal View As Inventor.View) Handles _selectEvents.OnSelect
SelectedObject = JustSelectedEntities.Item(1)
If TypeOf SelectedObject Is Face Then
If TypeOf SelectedObject.Geometry Is Plane Then
Me.SelectedObject = SelectedObject
Me.ModelPosition = ModelPosition
End If
End If
_stillSelecting = False
End Sub
End Class
