Here is an example that works with pick object. It isn't as intuitive as the other option due to no snap icon but it will pick the points out when the point cloud instance lights up as highlighted. Also has the advantage of letting the user orientate the view while picking.
It is a similar process but uses ISelection filter to find the nearest point.
I tried to add a snap icon InCanvasControl but it seems to work better without due to highlighting of instance overriding the canvas control. If you do use InCanvasControl then the centre of the image should be transparent so that clicking of the control doesn't prevent selection.
Public Function Obj_220821b(commandData As ExternalCommandData, ByRef message As String, elements As ElementSet) As Result
Dim IntUIApp As UIApplication = commandData.Application
Dim IntUIDoc As UIDocument = commandData.Application.ActiveUIDocument
Dim IntDoc As Document = IntUIDoc.Document
Dim R As Reference = Nothing
Try
R = IntUIDoc.Selection.PickObject(Selection.ObjectType.Element)
Catch ex As Exception
Return Result.Cancelled
End Try
Dim El As PointCloudInstance = IntDoc.GetElement(R)
Dim UIV As UIView = IntUIDoc.GetOpenUIViews.FirstOrDefault(Function(k) k.ViewId = IntUIDoc.ActiveGraphicalView.Id)
If UIV Is Nothing Then
Return Result.Cancelled
End If
'Dim PCSF As New PointCloudSelectionFilter(IntDoc, UIV, El, "c:\temp\SnapIco.bmp")
'Works better without snap icon due to highlighting of point cloud when selected.
Dim PCSF As New PointCloudSelectionFilter(IntDoc, UIV, El)
Dim R1 As Reference = Nothing
Try
R1 = IntUIDoc.Selection.PickObject(Selection.ObjectType.Element, PCSF)
Catch ex As Exception
GoTo Failure
End Try
If PCSF.FoundPoint.HasValue Then
Using Tx As New Transaction(IntDoc, "PT")
If Tx.Start = TransactionStatus.Started Then
Dim PTxyz As XYZ = CloudPointToXYZ(PCSF.FoundPoint)
Dim PTxyzMdl As XYZ = El.GetTransform.OfPoint(PTxyz)
PTxyzMdl.DrawPoint(IntDoc)
Tx.Commit()
End If
End Using
End If
GoTo Success
Failure:
PCSF.HideLast()
Return Result.Cancelled
Success:
PCSF.HideLast()
Return Result.Succeeded
End Function
The main part is the implementation of ISelection filter below:
Public Class PointCloudSelectionFilter
Implements Selection.ISelectionFilter
Private IntUIV As UIView = Nothing
Private IntV As View = Nothing
Private IntPC As PointCloudInstance = Nothing
Private IntFoundPoint As PointClouds.CloudPoint?
Private IntSPImg_Idx As Integer = -1
Private IntSPImg As InCanvasControlData = Nothing
Private IntTGM As TemporaryGraphicsManager = Nothing
Private IntSnapVisible As Boolean = False
Public ReadOnly Property FoundPoint As PointClouds.CloudPoint?
Get
Return IntFoundPoint
End Get
End Property
Public Sub New(D As Document, UIV As UIView, PC As PointCloudInstance, Optional SnapImagePath As String = "")
If D Is Nothing OrElse UIV Is Nothing OrElse PC Is Nothing Then
Throw New ArgumentNullException
End If
IntV = D.GetElement(UIV.ViewId)
If IntV.ViewType <> ViewType.ThreeD Then
Throw New ArgumentException("View of UIV to be View3D")
End If
IntUIV = UIV
IntPC = PC
If String.IsNullOrEmpty(SnapImagePath) = False Then
If IO.File.Exists(SnapImagePath) Then
IntSPImg = New InCanvasControlData(SnapImagePath)
IntTGM = TemporaryGraphicsManager.GetTemporaryGraphicsManager(D)
IntSPImg_Idx = IntTGM.AddControl(IntSPImg, IntV.Id)
IntTGM.SetVisibility(IntSPImg_Idx, False)
End If
End If
End Sub
Private Sub SetSnapIcon(Pos As XYZ)
If IntTGM Is Nothing Then
Exit Sub
End If
If IntSnapVisible = False Then
IntSnapVisible = True
IntTGM.SetVisibility(IntSPImg_Idx, True)
End If
IntSPImg.Position = Pos
IntTGM.UpdateControl(IntSPImg_Idx, IntSPImg)
End Sub
Private Sub HideSnapIcon()
If IntTGM Is Nothing Then
Exit Sub
End If
If IntSnapVisible = True Then
IntSnapVisible = False
IntTGM.SetVisibility(IntSPImg_Idx, False)
End If
End Sub
Public Sub HideLast()
If IntTGM Is Nothing Then
Exit Sub
End If
IntTGM.Clear()
End Sub
Private Function GetProjectionPlane() As Plane
Dim Origin As XYZ = IntUIV.GetZoomCorners(0)
Dim Dir As XYZ = IntV.ViewDirection
Return Plane.CreateByNormalAndOrigin(Dir, Origin)
End Function
Private Function ProjectedCP(PL As Plane, CP As PointClouds.CloudPoint, T As Transform) As Tuple(Of PointClouds.CloudPoint, UV, Double)
Dim Dist As Double = Double.PositiveInfinity
Dim UV As UV = Nothing
Dim CP0 As XYZ = CloudPointToXYZ(CP)
CP0 = T.OfPoint(CP0)
PL.Project(CP0, UV, Dist)
Return New Tuple(Of PointClouds.CloudPoint, UV, Double)(CP, UV, Dist)
End Function
Private Function ProjectedXYZ(PL As Plane, P As XYZ) As Tuple(Of PointClouds.CloudPoint, UV, Double)
Dim Dist As Double = Double.PositiveInfinity
Dim UV As UV = Nothing
PL.Project(P, UV, Dist)
Return New Tuple(Of PointClouds.CloudPoint, UV, Double)(Nothing, UV, Dist)
End Function
Public Function AllowElement(elem As Element) As Boolean Implements Selection.ISelectionFilter.AllowElement
' IntFoundPoint = Nothing
If elem.Document.ActiveView.Id <> IntV.Id Then
Return False
End If
If elem.GetType IsNot GetType(PointCloudInstance) Then Return False Else
Dim Inst As Instance = elem
Dim T As Transform = Inst.GetTransform
Dim GP As XYZ = elem.Document.ConvertScreenPositionToModel(IntUIV, Windows.Forms.Cursor.Position)
Dim ViewExtentModel As List(Of XYZ) = IntUIV.GetZoomCorners
Dim Min As XYZ = ViewExtentModel(0)
Dim Bx As XYZ = IntV.RightDirection
Dim By As XYZ = IntV.UpDirection
Dim Bz As XYZ = IntV.ViewDirection
Dim SZ As Double = 1 / 304.8
'Create filter box 2ft around global point
'Dim BtmPlane As Plane = Plane.CreateByNormalAndOrigin(Bz, GP - Bz) far clip not usd
Dim TopPlane As Plane = Plane.CreateByNormalAndOrigin(-Bz, Min + (Bz * SZ))
Dim LeftPlane As Plane = Plane.CreateByNormalAndOrigin(Bx, GP - (Bx * SZ))
Dim RightPlane As Plane = Plane.CreateByNormalAndOrigin(-Bx, GP + (Bx * SZ))
Dim FrontPlane As Plane = Plane.CreateByNormalAndOrigin(By, GP - (By * SZ))
Dim BackPlane As Plane = Plane.CreateByNormalAndOrigin(-By, GP + (By * SZ))
Dim PList As List(Of Plane) = {TopPlane, LeftPlane, RightPlane, FrontPlane, BackPlane}.ToList
Dim PCF As PointClouds.PointCloudFilter = PointClouds.PointCloudFilterFactory.CreateMultiPlaneFilter(PList, 5)
Dim PC As PointClouds.PointCollection = IntPC.GetPoints(PCF, 0.5 / 304.8, 100000) '1000000 max
If PC.Count = 0 Then
Return False
End If
Dim PL As Plane = GetProjectionPlane()
Dim CPs As List(Of Tuple(Of PointClouds.CloudPoint, UV, Double)) =
PC.Select(Function(q) ProjectedCP(PL, q, T)).ToList
Dim Check As Tuple(Of PointClouds.CloudPoint, UV, Double) = ProjectedXYZ(PL, GP)
Dim Dist As Double = CPs.Min(Function(q) q.Item2.DistanceTo(Check.Item2))
Dim CP_lst As List(Of Tuple(Of PointClouds.CloudPoint, UV, Double)) _
= CPs.FindAll(Function(q) q.Item2.DistanceTo(Check.Item2) = Dist)
If CP_lst.Count > 0 Then
IntFoundPoint = CP_lst(0).Item1
If IntTGM IsNot Nothing Then
Dim CPx As XYZ = CloudPointToXYZ(IntFoundPoint.Value)
CPx = T.OfPoint(CPx)
'shoft to view plane in front
Dim ProjDist As Double = Double.PositiveInfinity
PL.Project(CPx, Nothing, ProjDist)
CPx += (Bz * 2)
SetSnapIcon(CPx)
End If
Return True
Else
If IntTGM IsNot Nothing Then
HideSnapIcon()
End If
Return False
End If
End Function
Public Function AllowReference(reference As Reference, position As XYZ) As Boolean Implements Selection.ISelectionFilter.AllowReference
Return True
End Function
Private Function CloudPointToXYZ(CP As PointClouds.CloudPoint) As XYZ
Return New XYZ(CP.X, CP.Y, CP.Z)
End Function
End Class
Lastly this is key extension required:
<Extension>
Public Function ConvertScreenPositionToModel(D As Document, UIV As UIView, PT As System.Drawing.Point) As XYZ
Dim V As View = D.GetElement(UIV.ViewId)
Dim ViewExtentModel As List(Of XYZ) = UIV.GetZoomCorners
Dim T As Transform = Transform.Identity
T.BasisX = V.RightDirection
T.BasisY = V.UpDirection
T.BasisZ = V.ViewDirection
For i = 0 To 1
ViewExtentModel(i) = T.Inverse.OfPoint(ViewExtentModel(i))
Next
Dim ViewExtMin As XYZ = ViewExtentModel(0)
Dim ViewExtMax As XYZ = ViewExtentModel(1)
Dim SizeMdl As XYZ = ViewExtMax - ViewExtMin
Dim WindowExt As Rectangle = UIV.GetWindowRectangle
Dim WinW As Double = WindowExt.Right - WindowExt.Left
Dim WinH As Double = WindowExt.Bottom - WindowExt.Top
Dim CursorRelPosX As Double = PT.X - WindowExt.Left
Dim CursorRelPosY As Double = PT.Y - WindowExt.Top
Dim RatioX As Double = CursorRelPosX / WinW
Dim RatioY As Double = CursorRelPosY / WinH
Dim OffsetX As Double = SizeMdl.X * RatioX
Dim OffsetY As Double = SizeMdl.Y * RatioY
Dim TL As New XYZ(ViewExtMin.X, ViewExtMax.Y, ViewExtMin.Z)
Dim Pos As XYZ = TL + (OffsetX * XYZ.BasisX) - (OffsetY * XYZ.BasisY)
Dim Res As XYZ = T.OfPoint(Pos)
Return Res
End Function
Extension for converting mouse cursor position to model position, there are probably other ways of doing this floating about:
