By Adam Nagy
If you'd like to pick a point in the model then you can use the InteractionEvents.MouseEvents.OnMouseMove/OnMouseClick events. In these the ModelPosition parameter will give you a 3d point in the Target plane of the camera based on the mouse location. However, you may want to get back a point on the face under the cursor. In that case you could use the FindUsingRay/FindUsingVector functions.
I extended the sample code from Brian Ekins, which was for picking 2d points in a drawing, with the function that can transform the point from the Target plane onto the face. Since the Target plane could even be beyond the face that logically the point should be picked on, therefore first we'll transform the ModelPosition to the Screen plane, and then use that along with the view direction vector inside the FindUsingRay function to get back the face and the intersection point.
Here is the class that provides the functionality:
Option Explicit ' Declare the event objects Private WithEvents oInteractEvents As InteractionEvents Private WithEvents oMouseEvents As MouseEvents ' Declare a flag that's used to determine when selection stops. Private bStillSelecting As Boolean Private modelPoint As Point Public Function GetPoint() As Point ' Initialize flag. bStillSelecting = True ' Create an InteractionEvents object. Set oInteractEvents = _ ThisApplication.CommandManager.CreateInteractionEvents ' Ensure interaction is enabled. oInteractEvents.InteractionDisabled = False ' Set a reference to the mouse events. Set oMouseEvents = oInteractEvents.MouseEvents oMouseEvents.MouseMoveEnabled = True ' Start the InteractionEvents object. oInteractEvents.Start ' Loop until a (3D) point in the model is selected. Do While bStillSelecting DoEvents Loop ' Stop the InteractionEvents object. oInteractEvents.Stop ' Clean up. Set oMouseEvents = Nothing Set oInteractEvents = Nothing Set GetPoint = modelPoint End Function Private Sub oInteractEvents_OnTerminate() ' Set the flag to indicate we're done. bStillSelecting = False End Sub Private Function MovePtToFace(pt As Point, v As View) As Point ' Get the view direction, i.e. the vector pointing ' from the Eye to the Target Dim e2t As Vector Set e2t = v.Camera.eye.VectorTo(v.Camera.Target) ' The vector that will take the Model Point from the ' Target plane to the Screen plane is the opposite of e2t Dim m2s As Vector Set m2s = e2t.Copy m2s.ScaleBy (-1) Call pt.TranslateBy(m2s) Dim doc As PartDocument Set doc = v.Document ' Now we can shoot a ray from the Screen plane ' towards the model along the view direction to ' find the first object it hits and the intersection point Dim objects As ObjectsEnumerator Dim pts As ObjectsEnumerator Call doc.ComponentDefinition.FindUsingRay( _ pt, e2t.AsUnitVector(), _ 0.001, objects, pts) If pts.Count > 0 Then Set MovePtToFace = pts(1) End If End Function Private Sub oMouseEvents_OnMouseClick( _ ByVal Button As MouseButtonEnum, _ ByVal ShiftKeys As ShiftStateEnum, _ ByVal ModelPosition As Point, _ ByVal ViewPosition As Point2d, _ ByVal View As View) bStillSelecting = False ' ModelPosition will be on the Target Plane ' which is a plane parallel to the screen's plane ' but instead of including the Camera.Eye position ' this includes the Camera.Target position Set modelPoint = MovePtToFace(ModelPosition, View) 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 newPos As Point Set newPos = MovePtToFace(ModelPosition, View) If Not newPos Is Nothing Then Set ModelPosition = newPos ThisApplication.StatusBarText = _ ModelPosition.x & " : " & _ ModelPosition.y & " : " & _ ModelPosition.z End Sub
And here is the code that is using the above class:
Sub Get3dPoint() Dim oSelectedPoint As New clsGetPoint Dim modelPoint As Point Set modelPoint = oSelectedPoint.GetPoint If Not modelPoint Is Nothing Then Dim doc As PartDocument Set doc = ThisApplication.ActiveDocument Call doc.ComponentDefinition.WorkPoints.AddFixed(modelPoint) End If End Sub
Here is a picture of the tests I've done with the code, which places work points at the picked positions