选择集显示夹点

MickZ · 发表于 2016-10-25 09:15:16

本帖最后由 MickZ 于 2016-10-25 09:21 编辑

使用VLAX类结合VBA可以实现夹点显示。
VLAX类代码：

' 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))
'根据AutoCAD的版本判断使用的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

' 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)) 
        '根据<a href="http://bbs.mjtd.com/forum-41-1.html" target="_blank" class="relatedlink">AutoCAD</a>的版本判断使用的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

'使用直线选择集测试 
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

使用上面的代码可以再cad07里实现显示选择集的夹点,在09里Set VL = .GetInterfaceObject("VL.Application.16")这行代码取不到vl对象,所以无法显示夹点.

在cad09中怎么实现显示选择集的夹点呢?

wuyunpeng888 · 发表于 2018-4-14 15:34:33

你这代码有点复杂，其实选择完发个命令行就行(sssetfirst nil (ssget "P"))

wuyunpeng888 · 发表于 2019-1-12 10:27:45

我这也有一版
下面是lisp函数，放在窗体上的文本框里，VL类初始化时加载

(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)
)
)

加载代码如下

'加载选择集转换函数
strFileName = Environ("TEMP") & "\SelectionSet.lsp"
Open strFileName For Output As #5
Print #5, Form1.txtSelectionSet.Text
Close #5
VLFS.Item("Load").funcall strFileName
Kill strFileName

复制代码

VBA实现函数如下

'命名选择集显示夹点并选中
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

MickZ · 发表于 2016-10-27 14:59:20

人工顶一下,有大神吗?

dong20030432 · 发表于 2018-1-30 16:55:33

我的2006前几天还可以实现夹点显示，现在也不行了，搞不清楚怎么回事。取不到VL.Application.16。

dong20030432 · 发表于 2018-1-30 16:56:07

到这句就出错Set VL = .GetInterfaceObject("VL.Application.16")

dong20030432 · 发表于 2018-3-1 12:16:47

在With ThisDrawing.Application的前面加一句ThisDrawing.SendCommand "(vl-load-com)" & vbCr试一下。

wuyunpeng888 · 发表于 2018-3-5 16:40:39

vl不是16版本了

qwh923820 · 发表于 2018-4-23 15:01:25

谢谢分享！！！

wuyunpeng888 · 发表于 2018-4-24 12:30:34

你那是2006还是2016呀，高版本这个vl的com可能没有注册

jikasurvey · 发表于 2018-7-6 22:12:45

本帖最后由 jikasurvey 于 2018-7-6 22:14 编辑

wuyunpeng888 发表于 2018-4-14 15:34
你这代码有点复杂，其实选择完发个命令行就行(sssetfirst nil (ssget "P"))

你这个方法还是有个缺陷，如果发完命令(sssetfirst nil (ssget ""))后，程序并不马上退出，后面还有与CAD的交互操作，夹点只会一闪而过，并不会一直显示，再一个这个方法也不能通过空格或回车重复执行上次命令。不知道还有没有好的解决办法。

账号		自动登录	找回密码
密码			注册

选择集显示夹点

点评

点评