CAD-VBA实现夹点选择

Sub 测试_显示直线选择集夹点()
Dim ss As AcadSelectionSet
Dim objLine As AcadLine
Dim ftype(0 To 0) As Integer
Dim fdata(0 To 0) As Variant
Dim AutoSelect As Boolean

AutoSelect = 0 ' True
AppActivate ThisDrawing.Application.Caption '切换到CAD绘图状态
Set ss = 空集("SelectText")
On Error GoTo 处理错误

'创建过滤机制
ftype(0) = 0: fdata(0) = "*LINE" '直线
'选择符合条件的所有图元
If AutoSelect Then '自动选择方式
ss.Select acSelectionSetAll, , , ftype, fdata
Else '提示用户选择
ss.SelectOnScreen ftype, fdata
End If
If ss.Count = 0 Then Exit Sub

Call 显示夹点(ss) '显示夹点


Erase ftype: Erase fdata '删除数组
ss.Clear: ss.Delete '删除选择集
Set ss = Nothing: Set objLine = Nothing

Exit Sub
处理错误:
MsgBox Err.Description, vbCritical, "产生了以下错误:"
Err.Clear
End Sub

'显示选择集中对象的夹点,使用到VLAX类
Public Sub 显示夹点(ByRef ss As AcadSelectionSet)
Dim LispCode As New VLAX
Dim objEnt As AcadEntity

With LispCode
.EvalLispExpression "(setq ss (ssadd))"
For Each objEnt In ss
.EvalLispExpression "(ssadd " & "(handent " & Chr(34) & objEnt.Handle & Chr(34) & ")" & "ss" & ")"
Next
.EvalLispExpression "(sssetfirst nil ss)"
.EvalLispExpression "(setq ss nil)"
End With
Set LispCode = Nothing
ThisDrawing.Utility.Prompt "选择了" & ThisDrawing.PickfirstSelectionSet.Count & "个对象."
End Sub