To use the sample copy the WorkPointDrag sub into a code module. Create a new class module called clsDragWorkPoint and copy all of the rest of the code into it. Have a part document open that contains at least one fixed work point. Run the sample and drag the fixed work point.
Option Explicit
Public oDragWorkPoint As clsDragWorkPoint
Sub WorkPointDrag()
Set oDragWorkPoint = New clsDragWorkPoint
oDragWorkPoint.Initialize
End Sub
'*************************************************************
' The declarations and functions below need to be copied into
' a class module whose name is "clsDragWorkPoint". The name
' can be changed but you'll need to change the declaration in
' the calling function "WorkPointDrag" to use the new name.
Option Explicit
Private WithEvents oUserInputEvents As UserInputEvents
Private oIE As InteractionEvents
Private WithEvents oMouseEvents As MouseEvents
Private oIntGraphics As InteractionGraphics
Private oWP As WorkPoint
Public Sub Initialize()
Set oUserInputEvents = ThisApplication.CommandManager.UserInputEvents
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
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)
oIE.Start
End If
End If
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
Dim oProjectedPoint As Inventor.Point
Call ProjectPoint(ModelPosition, oWPDef.Point, oProjectedPoint)
' 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