Code:
Public Sub TestSelection()Dim oDrawDoc As Inventor.DrawingDocument
If ThisApplication.ActiveDocument.DocumentType = kDrawingDocumentObject Then
Set oDrawDoc = ThisApplication.ActiveDocument
Else
'Meldung erforderlich?
Exit Sub
End If
'Start Selektion
Dim selEdge1 As DrawingCurveSegment
Dim selEdge2 As DrawingCurveSegment
Set selEdge1 = ThisApplication.CommandManager.Pick(kDrawingCurveSegmentFilter, "Select DrawingCurve-1.")
Set selEdge2 = ThisApplication.CommandManager.Pick(kDrawingCurveSegmentFilter, "Select DrawingCurve-2.")
Dim oSheet As Sheet
Set oSheet = oDrawDoc.ActiveSheet
Dim oIntent1 As GeometryIntent
Set oIntent1 = oSheet.CreateGeometryIntent(selEdge1.Parent)
Dim oIntent2 As GeometryIntent
Set oIntent2 = oSheet.CreateGeometryIntent(selEdge2.Parent)
Dim oPt As Point2d
Set oPt = TestGetDrawingPoint
Dim oLinDim As LinearGeneralDimension
Set oLinDim = oSheet.DrawingDimensions.GeneralDimensions.AddLinear(oPt, oIntent1, oIntent2)
'oLinDim Stil hier anpassen
End Sub
Public Function TestGetDrawingPoint() As Point2d
Dim getPoint As New clsGetPoint
Dim pnt As Point2d
Do
Set pnt = getPoint.GetDrawingPoint("Click the desired location", kLeftMouseButton)
If Not pnt Is Nothing Then
Set TestGetDrawingPoint = pnt
Exit Function
'MsgBox "Click is at " & Format(pnt.x, "0.0000") & ", " & Format(pnt.Y, "0.0000")
End If
Loop While Not pnt Is Nothing
End Function