Create WorkPlane by Point and Line

[FarrenYoung]

I am trying to create a workplane by a point and a line.  I can do this maually, but have not been able to reproduce this in code.

Does anyone know how I can do this?

BTW: I realize I can create a fixed workplane by using the point, the edge, and an edge perpendicular to the edge, but I cannot have this as a fixed workplane.

[adam.nagy · Accepted solution]

Hi Farren,

Not sure how far you got with your investigation so I just write down what I checked.

If I created a Work Plane through the UI as you pointed out and then checked in VBA the WorkPlane.Defintion property then I could see that it was NormalToCurveWorkPlaneDef, so I would need to use the WorkPlanes.AddByNormalToCurve function.

If the mid point of the edge is selected then the Definition's Point property is not set, whereas if the start or end point is set then that property is set to the appropriate Vertex of the edge.

I could do the latter but not the mid point version:

Sub AddWorkplane()
    Dim doc As PartDocument
    Set doc = ThisApplication.ActiveDocument
    
    ' Select an edge and run this code
    Dim e As Edge
    Set e = doc.SelectSet(1)
    
    Dim wp As WorkPlane
    
    ' This succeeds
    Set wp = doc.ComponentDefinition.WorkPlanes.AddByNormalToCurve(e, e.StartVertex)
    
    ' This does not work :(
    Set wp = doc.ComponentDefinition.WorkPlanes.AddByNormalToCurve(e, Nothing)
End Sub

I checked with others and it does not seem possible at the moment. Sorry 😞

I'm logging this in our system. 

Cheers,

[ShigekazuSaito]

Hi Farren,

It does not seem to be able to create a WorkPlane using the MidPoint directly.

I think WorkPlane could be created if they create a WorkPoint.

Public Sub Test2()
   Dim doc As PartDocument
    Set doc = ThisApplication.ActiveDocument
    
    ' Select an edge and run this code
    Dim e As Edge
    Set e = doc.SelectSet(1)
    
    Dim wp As WorkPlane
    
    ' This succeeds
'    Set wp = doc.ComponentDefinition.WorkPlanes.AddByNormalToCurve(e, e.StartVertex)
    
    ' This does not work :(
'    Set wp = doc.ComponentDefinition.WorkPlanes.AddByNormalToCurve(e, Nothing)
 
    Dim oWkPoint As WorkPoint
    Set oWkPoint = doc.ComponentDefinition.WorkPoints.AddFixed(e.Geometry.MidPoint)
    Set wp = doc.ComponentDefinition.WorkPlanes.AddByNormalToCurve(e, oWkPoint)
 
End Sub

 So, it is the following, if any point on the edge.

>>>>>>>>>>>>>>>>>>>>>>>>>>> 
Option Explicit
Public Sub SelectForEdgePoint()
  Dim oSelect As New clsSelect
  Dim doc As PartDocument
  Set doc = ThisApplication.ActiveDocument
  If doc Is Nothing Then
      MsgBox "Plese Open the Partfile"
      Exit Sub
  End If
  
  Dim e As Edge
  Dim oPoint As Point
  Call oSelect.StartSelection(e, oPoint)
    
  Dim wp As WorkPlane
  Dim oWkPoint As WorkPoint
  
  Set oWkPoint = doc.ComponentDefinition.WorkPoints.AddFixed(oPoint)
  Set wp = doc.ComponentDefinition.WorkPlanes.AddByNormalToCurve(e, oWkPoint)
 
End Sub
>>>>>>>>>>>>>>>>>>>>>>>>>>> 
 
>>>> Class module Begin >>>> 
 
Private WithEvents oInteraction As InteractionEvents
Private WithEvents oSelect As SelectEvents
Private bStillSelecting As Boolean
 
Public oPt As Point
Public oObj As Edge
 
Public Sub StartSelection(ByRef oEdge As Edge, ByRef oPoint As Point)
    bStillSelecting = True
    Set oInteraction = ThisApplication.CommandManager.CreateInteractionEvents
    
    Set oSelect = oInteraction.SelectEvents
    oSelect.AddSelectionFilter kPartEdgeFilter
 
     oSelect.SingleSelectEnabled = True
    
    oInteraction.Start
    Do While bStillSelecting
      ThisApplication.UserInterfaceManager.DoEvents
    Loop
    oInteraction.Stop
    
    Set oSelectEvents = Nothing
    Set oInteractEvents = Nothing
    Set oEdge = oObj
    Set oPoint = oPt
End Sub
 
Private Sub oSelect_OnSelect(ByVal JustSelectedEntities As ObjectsEnumerator, _
          ByVal SelectionDevice As SelectionDeviceEnum, ByVal ModelPosition As Point, _
          ByVal ViewPosition As Point2d, ByVal View As View)
          
    bStillSelecting = False
    Set oObj = JustSelectedEntities.Item(1)
    Set oPt = ModelPosition
End Sub
>>>> Class module End >>>> 
 

[FarrenYoung]

Hi ShigekazuSaito,
I truly appreciate the help you have offered, but unfortunately the method you show fixes the plane to the workpoint. When the part changes size the workpoint does not move and thus the work plane does not move.

[ShigekazuSaito]

Hi Farren

It can be dragging the WorkPoint using UserInputEvents.OnDrag.
You are able to use the "OnDrag Event - dragging a WorkPoint API Sample" sample of the API reference (admapi_17_0.chm).
The sample will be dragging anywhere in three-dimensional space.
Therefore, if you want the point that move on the edge , you can use together SelectEvents.OnPreSelectMouseMove.

The following is a sample with additional modification.

Option Explicit
Public oDragWorkPoint As clsDragWorkPoint

Sub WorkPointDrag()

    Set oDragWorkPoint = New clsDragWorkPoint
    oDragWorkPoint.Initialize

    ' Stop the command
    ThisApplication.CommandManager.StopActiveCommand

End Sub

Option Explicit
Private WithEvents oUserInputEvents As UserInputEvents
Private oIE As InteractionEvents
Private WithEvents oMouseEvents As MouseEvents
Private oIntGraphics As InteractionGraphics
Private oWP As WorkPoint

'---  Add  Begin ----
Private WithEvents oSelect As SelectEvents
Dim oModelPoint As Point
'---  Add  End ----

Dim bGettingPoint As Boolean
Dim oPnt As Point

Public Sub Initialize()

    Set oUserInputEvents = ThisApplication.CommandManager.UserInputEvents

'    Set oUserInputEvents = ThisApplication.CommandManager.MouseEvents

End Sub

'---  Add  Begin ----
Private Sub oSelect_OnPreSelectMouseMove(ByVal PreSelectEntity As Object, ByVal ModelPosition As Point, ByVal ViewPosition As Point2d, ByVal View As View)
  Set oModelPoint = ModelPosition
End Sub
'---  Add  End ----
Private Sub oUserInputEvents_OnActivateCommand(ByVal CommandName As String, ByVal Context As NameValueMap)
'  MsgBox "OnActivateCommand"
End Sub

Private Sub oUserInputEvents_OnContextMenu(ByVal SelectionDevice As SelectionDeviceEnum, ByVal AdditionalInfo As NameValueMap, ByVal CommandBar As CommandBar)
  'MsgBox "OnContextMenu"
End Sub

Private Sub oUserInputEvents_OnDrag( _
        ByVal DragState As Inventor.DragStateEnum, _
        ByVal ShiftKeys As Inventor.ShiftStateEnum, _
        ByVal ModelPosition As Inventor.Point, _
        ByVal ViewPosition As Inventor.Point2d, _
        ByVal View As Inventor.View, _
        ByVal AdditionalInfo As Inventor.NameValueMap, _
        HandlingCode As Inventor.HandlingCodeEnum)

  Dim oSS As SelectSet
  Set oSS = ThisApplication.ActiveDocument.SelectSet
'  MsgBox "oUserInputEvents_OnDrag" & "HandlingCode : " & HandlingCode
  If DragState = kDragStateDragHandlerSelection Then
  
    If oSS.Count = 1 And oSS.Item(1).Type = kWorkPointObject Then
    
      Set oWP = oSS.Item(1)
      
      If oWP.DefinitionType = kFixedWorkPoint Then
        HandlingCode = kEventCanceled
        Set oIE = ThisApplication.CommandManager.CreateInteractionEvents
        Set oMouseEvents = oIE.MouseEvents
        oMouseEvents.MouseMoveEnabled = True
        
        Set oIntGraphics = oIE.InteractionGraphics
        Call oIE.SetCursor(kCursorBuiltInCommonSketchDrag)
        
'---  Add  Begin ----
    Set oSelect = oIE.SelectEvents
    oSelect.AddSelectionFilter kPartEdgeFilter
    oSelect.SingleSelectEnabled = True
'---  Add  End ----        
        oIE.Start
        
      End If
    End If
    
'    HandlingCode = kEventNotHandled
    HandlingCode = kEventHandled
  End If
  If DragState = kDragStateEndDrag Then
    MsgBox "kDragStateEndDrag"
    HandlingCode = kEventNotHandled
  End If

End Sub
Private Sub oMouseEvents_OnMouseMove(ByVal Button As MouseButtonEnum, ByVal ShiftKeys As ShiftStateEnum, ByVal ModelPosition As Point, ByVal ViewPosition As Point2d, ByVal View As View)
    Dim oSS As SelectSet
    Set oSS = ThisApplication.ActiveDocument.SelectSet

    If oSS.Count = 1 And oSS.Item(1).Type = kWorkPointObject Then

        Dim oWPDef As FixedWorkPointDef
        Set oWPDef = oWP.Definition

        Dim oProjectedPoint As Inventor.Point
        Call ProjectPoint(ModelPosition, oWPDef.Point, oProjectedPoint)

        ' Set a reference to the transient geometry object for user later.
        Dim oTransGeom As TransientGeometry
        Set oTransGeom = ThisApplication.TransientGeometry

        ' Create a graphics data set object. This object contains all of the
        ' information used to define the graphics.
        Dim oDataSets As GraphicsDataSets
        Set oDataSets = oIntGraphics.GraphicsDataSets

        If oDataSets.Count <> 0 Then
            oDataSets.Item(1).Delete
        End If

        ' Create a coordinate set.
        Dim oCoordSet As GraphicsCoordinateSet
        Set oCoordSet = oDataSets.CreateCoordinateSet(1)

        ' Create an array that contains coordinates that define a set
        ' of outwardly spiraling points.
        Dim oPointCoords(1 To 3) As Double
        ' Define the X, Y, and Z components of the point.
        oPointCoords(1) = oProjectedPoint.X
        oPointCoords(2) = oProjectedPoint.Y
        oPointCoords(3) = oProjectedPoint.Z

        ' Assign the points into the coordinate set.
        Call oCoordSet.PutCoordinates(oPointCoords)

        ' Create the ClientGraphics object.
        Dim oClientGraphics As ClientGraphics
        Set oClientGraphics = oIntGraphics.PreviewClientGraphics

        If oClientGraphics.Count <> 0 Then
            oClientGraphics.Item(1).Delete
        End If

        ' Create a new graphics node within the client graphics objects.
        Dim oPtNode As GraphicsNode
        Set oPtNode = oClientGraphics.AddNode(1)

        ' Create a PointGraphics object within the node.
        Dim oPtGraphics As PointGraphics
        Set oPtGraphics = oPtNode.AddPointGraphics

        ' Assign the coordinate set to the line graphics.
        oPtGraphics.CoordinateSet = oCoordSet
        oPtGraphics.PointRenderStyle = kCrossPointStyle
        ThisApplication.ActiveView.Update
    End If
End Sub
Private Sub oMouseEvents_OnMouseUp( _
            ByVal Button As MouseButtonEnum, _
            ByVal ShiftKeys As ShiftStateEnum, _
            ByVal ModelPosition As Point, _
            ByVal ViewPosition As Point2d, _
            ByVal View As View)

  Dim oSS As SelectSet
  Set oSS = ThisApplication.ActiveDocument.SelectSet
  
  If oSS.Count = 1 And oSS.Item(1).Type = kWorkPointObject Then
  
    Dim oWPDef As FixedWorkPointDef
    Set oWPDef = oWP.Definition
    
'---  Add  Begin ----
    Dim oMpoint As Point
    Set oMpoint = oModelPoint
'---  Add  End ----    
    Dim oProjectedPoint As Inventor.Point
'--- Modify Begin ----
'    Call ProjectPoint(ModelPosition, oWPDef.Point, oProjectedPoint)
    Call ProjectPoint(oMpoint, oWPDef.Point, oProjectedPoint)
'--- Modify End ----
    ' Reposition the fixed work point
    oWPDef.Point = oProjectedPoint
    ThisApplication.ActiveDocument.Update
    oIE.Stop
    
    Set oWP = Nothing
  
  End If
  
End Sub

' Project the ModelPosition to a plane parallel to the
' X-Y plane on which the work point currently is.

Private Sub ProjectPoint(ByVal ModelPosition As Inventor.Point, ByVal WorkPointPosition As Inventor.Point, ProjectedPoint As Inventor.Point)

    ' Set a reference to the camera object
    Dim oCamera As Inventor.Camera
    Set oCamera = ThisApplication.ActiveView.Camera

    Dim oVec As Vector
    Set oVec = oCamera.Eye.VectorTo(oCamera.Target)

    Dim oLine As Line
    Set oLine = ThisApplication.TransientGeometry.CreateLine(ModelPosition, oVec)

    ' Create the z-axis vector
    Dim oZAxis As Vector
    Set oZAxis = ThisApplication.TransientGeometry.CreateVector(0, 0, 1)

    ' Create a plane parallel to the X-Y plane
    Dim oWPPlane As Plane
    Set oWPPlane = ThisApplication.TransientGeometry.CreatePlane(WorkPointPosition, oZAxis)

    Set ProjectedPoint = oWPPlane.IntersectWithLine(oLine)

End Sub

Private Sub oUserInputEvents_OnTerminateCommand(ByVal CommandName As String, ByVal Context As NameValueMap)
  MsgBox "OnTerminateCommand"
End Sub

Hope this help.

Shigekazu Saito
Developer Technical Services
Autodesk Developer Network

[FarrenYoung]

Hi Shigekazu Saito,

Thanks again for the help you have offered; however, I am using these parts with Autodesk Inventor ETO so the parts are not modified by the user, but by a built in library that builds new copies of the base parts I specify and changes parameters to drive the shape/size of the part. Because of this I need the work planes to be tied to the edges and not some fixed workpoint.

Thanks,
Farren

[adam.nagy]

Hi Farren,

Oops, not sure how I managed to miss this workaround esepcially after seeing Saito-san's code. 😞

You could create a workpoint that is fixed to the middle of the edge and use that to create a workplane:

Sub AddWorkplane()
    Dim doc As PartDocument
    Set doc = ThisApplication.ActiveDocument
    
    Dim cd As PartComponentDefinition
    Set cd = doc.ComponentDefinition
    
    ' Select an edge and run this code
    Dim e As Edge
    Set e = doc.SelectSet(1)
    
    Dim wp As WorkPlane
    
    ' This succeeds
    Set wp = cd.WorkPlanes.AddByNormalToCurve(e, e.StartVertex)
    
    Dim pt As WorkPoint
    Set pt = cd.WorkPoints.AddByMidPoint(e, True)
    
    ' This works too
    Set wp = cd.WorkPlanes.AddByNormalToCurve(e, pt)
End Sub

Cheers,