I have found another issue / bug regarding this method.
In Inventor 2020 when I am creating a GeometryIntent object, returned object property "PointOnSheet" returns Nothing (So I get an an error in the script below)
In Inventor 2024 I don't get an error in the watch window I can see that correct point is assigned to GeometryIntent object. BUT when I am creating general dimensions it chooses wrong point.
Below is an image of the result I get from my script. It's really frustrating (I have walked around the previous bug in this thread by sending a function an expected point), but I do not have any ideas how to escape this one. Any help?
Const Tolerance As Double = 1E-19
Sub Main()
AddThicknessDimensionWithExtremumCall
'ShowObjectData
End Sub
Sub AddThicknessDimensionWithExtremumCall()
Dim oSheet As Sheet
Set oSheet = ThisApplication.ActiveDocument.ActiveSheet
' Assuming the projected view is the 3rd view on the sheet
Dim oView As DrawingView
Set oView = oSheet.DrawingViews.Item(3)
Dim minPoint As Point2d, maxPoint As Point2d
Dim minXIntent As GeometryIntent, maxXIntent As GeometryIntent
' Call the GetExtremumPoints function with oppositeIsMax set to True
Dim extremumPoints As Variant
extremumPoints = GetExtremumPoints(oView, "X", True)
Set minPoint = extremumPoints(0)
Set maxPoint = extremumPoints(1)
Set minXIntent = extremumPoints(2)
Set maxXIntent = extremumPoints(3)
Dim oTG As TransientGeometry
Set oTG = ThisApplication.TransientGeometry
' Set the position for the dimension text slightly above the projected view
Dim textPoint As Point2d
Set textPoint = oTG.CreatePoint2d((minPoint.X + maxPoint.X) / 2, oView.Position.Y + oView.Height / 2 + 5)
' Add the dimension
If Not minXIntent Is Nothing And Not maxXIntent Is Nothing Then
Call oSheet.DrawingDimensions.GeneralDimensions.AddLinear(textPoint, minXIntent, maxXIntent, DimensionTypeEnum.kHorizontalDimensionType)
End If
End Sub
Function GetExtremumPoints(view As DrawingView, axis As String, oppositeIsMax As Boolean) As Variant
Dim minValue As Double
Dim maxValue As Double
Dim oppositeMinValue As Double
Dim oppositeMaxValue As Double
Dim minPoint As Point2d
Dim maxPoint As Point2d
Dim minIntent As GeometryIntent
Dim maxIntent As GeometryIntent
minValue = 999999
maxValue = -999999
If oppositeIsMax Then
oppositeMinValue = -999999
oppositeMaxValue = -999999
Else
oppositeMinValue = 999999
oppositeMaxValue = -999999
End If
Dim curve As DrawingCurve
Dim segment As DrawingCurveSegment
For Each curve In view.DrawingCurves
For Each segment In curve.Segments
If segment.Visible Then
Dim start As Point2d
Dim ending As Point2d
Set start = segment.StartPoint
Set ending = segment.endPoint
If Not start Is Nothing And Not ending Is Nothing Then
Dim primaryStartValue As Double
Dim primaryEndValue As Double
Dim oppositeStartValue As Double
Dim oppositeEndValue As Double
If axis = "X" Then
primaryStartValue = start.X
primaryEndValue = ending.X
oppositeStartValue = start.Y
oppositeEndValue = ending.Y
Else
primaryStartValue = start.Y
primaryEndValue = ending.Y
oppositeStartValue = start.X
oppositeEndValue = ending.X
End If
Dim updateMin As Boolean
Dim updateMax As Boolean
If (start.X < 43.5993 Or ending.X < 43.5993) Then
'And (start.Y < 26.1 Or ending.Y < 26.1)
Debug.Print ("TRUE")
Debug.Print (Abs(primaryStartValue - minValue) < Tolerance)
' Code to execute if condition is true
End If
' Update min value point considering opposite value as tie-breaker
updateMin = False
If minValue - primaryStartValue > Tolerance Then
updateMin = True
ElseIf Abs(primaryStartValue - minValue) < Tolerance And _
OppositeIsValid(oppositeIsMax, oppositeMinValue, oppositeStartValue, oppositeEndValue) Then
Debug.Print ("Update minimum values start point!")
updateMin = True
End If
If updateMin Then
minValue = primaryStartValue
oppositeMinValue = oppositeStartValue
Set minPoint = start
Set minIntent = CreateAndVerifyGeometryIntent(curve, start)
End If
updateMin = False
If minValue - primaryEndValue > Tolerance Then
updateMin = True
ElseIf Abs(primaryEndValue - minValue) < Tolerance And _
OppositeIsValid(oppositeIsMax, oppositeMinValue, oppositeStartValue, oppositeEndValue) Then
Debug.Print ("Update minimum values end point!")
updateMin = True
End If
If updateMin Then
minValue = primaryEndValue
oppositeMinValue = oppositeEndValue
Set minPoint = ending
Set minIntent = CreateAndVerifyGeometryIntent(curve, ending)
End If
' Similar logic for max value point
updateMax = False
If primaryStartValue > maxValue Then updateMax = True
If primaryStartValue = maxValue And _
OppositeIsValid(oppositeIsMax, oppositeMaxValue, oppositeStartValue, oppositeEndValue) Then updateMax = True
If updateMax Then
maxValue = primaryStartValue
oppositeMaxValue = oppositeStartValue
Set maxPoint = start
Set maxIntent = CreateAndVerifyGeometryIntent(curve, start)
End If
updateMax = False
If primaryEndValue > maxValue Then updateMax = True
If primaryEndValue = maxValue And _
OppositeIsValid(oppositeIsMax, oppositeMaxValue, oppositeStartValue, oppositeEndValue) Then updateMax = True
If updateMax Then
maxValue = primaryEndValue
oppositeMaxValue = oppositeEndValue
Set maxPoint = ending
Set maxIntent = CreateAndVerifyGeometryIntent(curve, ending)
End If
Else
Debug.Print ("START OR END IS NULL")
End If
Else
Debug.Print ("SEGMENT IS NOT VISIBLE!")
End If
Next segment
Next curve
' Return as an array
GetExtremumPoints = Array(minPoint, maxPoint, minIntent, maxIntent)
End Function
Function OppositeIsValid(oppositeIsMax As Boolean, oppositeValue As Double, oppositeStartValue As Double, oppositeEndValue As Double) As Boolean
If oppositeIsMax Then
OppositeIsValid = (oppositeStartValue > oppositeValue) Or (oppositeEndValue > oppositeValue)
Else
OppositeIsValid = (oppositeStartValue < oppositeValue) Or (oppositeEndValue < oppositeValue)
End If
'Debug.Print ("Opposite is valid: " & OppositeIsValid)
End Function
Function CreateAndVerifyGeometryIntent(curve As DrawingCurve, expectedPoint As Point2d) As GeometryIntent
Dim drawDoc As DrawingDocument
Set drawDoc = ThisApplication.ActiveDocument
Dim oSheet As Sheet
Set oSheet = drawDoc.ActiveSheet
Dim intent As GeometryIntent
Set intent = oSheet.CreateGeometryIntent(curve, PointIntentEnum.kStartPointIntent)
' Verify if the intent point matches the expected point, if not, try the alternate intent
If Not PointsAreEqual(intent.PointOnSheet, expectedPoint) Then
Set intent = oSheet.CreateGeometryIntent(curve, PointIntentEnum.kEndPointIntent)
End If
If Not PointsAreEqual(intent.PointOnSheet, expectedPoint) Then
Debug.Print ("Couldn't find the expected point for curve in ")
Err.Raise vbObjectError + 1, "CreateAndVerifyGeometryIntent", "Couldn't find the expected point for curve in " & ActiveSheet.Name
End If
Set CreateAndVerifyGeometryIntent = intent
End Function
' Helper function to compare two points for equality
Function PointsAreEqual(point1 As Point2d, point2 As Point2d) As Boolean
'If (point1 Is Nothing) Or (point2 Is Nothing) Then
'PointsAreEqual = False
'Else
'Const Tolerance As Double = 0.001 ' Define an appropriate tolerance
PointsAreEqual = (Abs(point1.X - point2.X) < Tolerance) And (Abs(point1.Y - point2.Y) < Tolerance)
'End If
End Function
Public Sub ShowObjectData()
' Set a reference to the select set of the active document.
Dim oSelectSet As SelectSet
Set oSelectSet = ThisApplication.ActiveDocument.SelectSet
' Check to make sure a single item was selected.
If oSelectSet.Count = 1 Then
Dim oSegment As DrawingCurveSegment
Set oSegment = oSelectSet.Item(1)
' Print the segment's geometry type
MsgBox "Geometry Type: " & oSegment.GeometryType
' Print start and end point values
MsgBox "Start Point: X=" & oSegment.StartPoint.X & ", Y=" & oSegment.StartPoint.Y & vbCrLf & _
"End Point: X=" & oSegment.endPoint.X & ", Y=" & oSegment.endPoint.Y
Exit Sub
Else
MsgBox "You must select a single object."
Exit Sub
End If
End Sub
P.S the unusual way of number comparing is because I get unexpected results by simply using "< ; > ; =" signs. If I get it right it's wrong because big float numbers doesn't return the same value in bits sometimes. Had to spend a chunk of time to debug that..
