选择集显示夹点

' VLAX.CLS v2.0 (Last updated 8/1/2003)
' Copyright 1999-2001 by Frank Oquendo
'
' 该程序由乐筑天下修改支持2004版本
' 
'
' Permission to use, copy, modify, and distribute this software
' for any purpose and without fee is hereby granted, provided
' that the above copyright notice appears in all copies and
' that both that copyright notice and the limited warranty and
' restricted rights notice below appear in all supporting
' documentation.
'
' FRANK OQUENDO (THE AUTHOR) PROVIDES THIS PROGRAM "AS IS" AND WITH
' ALL FAULTS. THE AUTHOR SPECIFICALLY DISCLAIMS ANY IMPLIED WARRANTY
' OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR USE.  THE AUTHOR
' DOES NOT WARRANT THAT THE OPERATION OF THE PROGRAM WILL BE
' UNINTERRUPTED OR ERROR FREE.
'
' Use, duplication, or disclosure by the U.S. Government is subject to
' restrictions set forth in FAR 52.227-19 (Commercial Computer
' Software - Restricted Rights) and DFAR 252.227-7013(c)(1)(ii)
' (Rights in Technical Data and Computer Software), as applicable.
'
' VLAX.cls allows developers to evaluate AutoLISP expressions from
' Visual Basic or VBA
'
' Notes:
' All code for this class module is publicly available througout various posts
' 
' claim copyright or authorship on code presented in these posts, only on this
' compilation of that code. In addition, a great big "Thank you!" to Cyrille Fauvel
' demonstrating the use of the VisualLISP ActiveX Module.
'
' Dependencies:
' Use of this class module requires the following application:
' 1. VisualLISP
Private VL As Object
Private VLF As Object
Private Sub Class_Initialize()
    Dim AcadVersion As Integer
    With ThisDrawing.Application
        AcadVersion = Val(Left(.Version, 2))
        '根据的版本判断使用的VL库类型
        Select Case AcadVersion
            Case Is = 15
                Set VL = .GetInterfaceObject("VL.Application.1")
            Case Is >= 16
                Set VL = .GetInterfaceObject("VL.Application.16")
        End Select
    End With
    Set VLF = VL.ActiveDocument.Functions
End Sub
Public Function EvalLispExpression(lispStatement As String)
    '根据LISP表达式调用函数
    Dim sym As Object, ret As Object, retVal
    Set sym = VLF.Item("read").funcall(lispStatement)
    On Error Resume Next
    retVal = VLF.Item("eval").funcall(sym)
    If Err Then
        EvalLispExpression = ""
    Else
        EvalLispExpression = retVal
    End If
    On Error GoTo 0
End Function
Public Sub SetLispSymbol(symbolName As String, value)
    Dim sym As Object, ret, symValue
    symValue = value
    Set sym = VLF.Item("read").funcall(symbolName)
    ret = VLF.Item("set").funcall(sym, symValue)
    EvalLispExpression "(defun translate-variant (data) (cond ((= (type data) 'list) (mapcar 'translate-variant data)) ((= (type data) 'variant) (translate-variant (vlax-variant-value data))) ((= (type data) 'safearray) (mapcar 'translate-variant (vlax-safearray->list data))) (t data)))"
    EvalLispExpression "(setq " & symbolName & "(translate-variant " & symbolName & "))"
    EvalLispExpression "(setq translate-variant nil)"
End Sub
Public Function GetLispSymbol(symbolName As String)
    Dim sym As Object, ret, symValue
    symValue = value
    Set sym = VLF.Item("read").funcall(symbolName)
    GetLispSymbol = VLF.Item("eval").funcall(sym)
End Function
Public Function GetLispList(symbolName As String) As Variant
    Dim sym As Object, list As Object
    Dim Count, elements(), i As Long
    Set sym = VLF.Item("read").funcall(symbolName)
    Set list = VLF.Item("eval").funcall(sym)
    Count = VLF.Item("length").funcall(list)
    ReDim elements(0 To Count - 1) As Variant
    For i = 0 To Count - 1
        elements(i) = VLF.Item("nth").funcall(i, list)
    Next
    GetLispList = elements
End Function
Public Sub NullifySymbol(ParamArray symbolName())
    Dim i As Integer
    For i = LBound(symbolName) To UBound(symbolName)
        EvalLispExpression "(setq " & CStr(symbolName(i)) & " nil)"
    Next
End Sub
Private Sub Class_Terminate()
    '类析构时，释放内存
    Set VLF = Nothing
    Set VL = Nothing
End Sub

'使用直线选择集测试
Sub ShowSelectLineCrips()
    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 = True
    On Error Resume Next
    ThisDrawing.SelectionSets("SelectText").Delete
    Set ss = ThisDrawing.SelectionSets.Add("SelectText")
    On Error GoTo 0
    On Error GoTo ErrHandle
    '创建过滤机制
    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
    '显示夹点
    ShowSelectionSetCrips ss
    '删除数组
    Erase fType: Erase fData
    '删除选择集
    ss.Clear: ss.Delete
    Set ss = Nothing
    Set objLine = Nothing
    Exit Sub
ErrHandle:
    MsgBox Err.Description, vbCritical, "产生了以下错误:"
    Err.Clear
End Sub
'显示选择集中对象的夹点
Public Sub ShowSelectionSetCrips(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
    'MsgBox "您选择了" & ThisDrawing.PickfirstSelectionSet.Count & "个对象"
End Sub

(defun VBASelectionSet2ALSelectionSet(VBA_SSName / obj ss sss AL_SS) ;命名选择集转换成aut
  (setq sss (vlax-get-property (vlax-get-property (vlax-get-acad-object) 'ActiveDocument) 'SelectionSets))
  (setq ss (vlax-invoke-method sss 'Item VBA_SSName))
  (setq AL_SS(ssadd))
  (vlax-for obj ss 
    (ssadd (vlax-vla-object->ename obj) AL_SS)
  )
) 

'命名选择集显示夹点并选中
Public Sub ShowPickPoints(ByVal selectionSet As Object, ByVal blnOpen As Boolean)
If blnOpen = True Then
    vlax.SetLispSymbol "ShowPickPoints_sset", selectionSet.Name
    
    vlax.EvalLispExpression "(sssetfirst nil (VBASelectionSet2ALSelectionSet ShowPickPoints_sset))"
    vlax.NullifySymbol "ShowPickPoints_sset"
Else
    vlax.EvalLispExpression "(sssetfirst nil)"
End If
End Sub