明经CAD社区

 找回密码
 注册

QQ登录

只需一步,快速开始

搜索
查看: 3485|回复: 24

选择集显示夹点

[复制链接]
发表于 2016-10-25 09:15 | 显示全部楼层 |阅读模式
本帖最后由 MickZ 于 2016-10-25 09:21 编辑

使用VLAX类结合VBA可以实现夹点显示。
VLAX类代码:
  1. ' VLAX.CLS v2.0 (Last updated 8/1/2003)
  2. ' Copyright 1999-2001 by Frank Oquendo
  3. '
  4. ' 该程序由明经通道修改支持2004版本
  5. '
  6. '
  7. ' Permission to use, copy, modify, and distribute this software
  8. ' for any purpose and without fee is hereby granted, provided
  9. ' that the above copyright notice appears in all copies and
  10. ' that both that copyright notice and the limited warranty and
  11. ' restricted rights notice below appear in all supporting
  12. ' documentation.
  13. '
  14. ' FRANK OQUENDO (THE AUTHOR) PROVIDES THIS PROGRAM "AS IS" AND WITH
  15. ' ALL FAULTS. THE AUTHOR SPECIFICALLY DISCLAIMS ANY IMPLIED WARRANTY
  16. ' OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR USE.  THE AUTHOR
  17. ' DOES NOT WARRANT THAT THE OPERATION OF THE PROGRAM WILL BE
  18. ' UNINTERRUPTED OR ERROR FREE.
  19. '
  20. ' Use, duplication, or disclosure by the U.S. Government is subject to
  21. ' restrictions set forth in FAR 52.227-19 (Commercial Computer
  22. ' Software - Restricted Rights) and DFAR 252.227-7013(c)(1)(ii)
  23. ' (Rights in Technical Data and Computer Software), as applicable.
  24. '
  25. ' VLAX.cls allows developers to evaluate AutoLISP expressions from
  26. ' Visual Basic or VBA
  27. '
  28. ' Notes:
  29. ' All code for this class module is publicly available througout various posts
  30. '
  31. ' claim copyright or authorship on code presented in these posts, only on this
  32. ' compilation of that code. In addition, a great big "Thank you!" to Cyrille Fauvel
  33. ' demonstrating the use of the VisualLISP ActiveX Module.
  34. '
  35. ' Dependencies:
  36. ' Use of this class module requires the following application:
  37. ' 1. VisualLISP
  38. Private VL As Object
  39. Private VLF As Object
  40. Private Sub Class_Initialize()
  41.     Dim AcadVersion As Integer
  42.     With ThisDrawing.Application
  43.         AcadVersion = Val(Left(.Version, 2))
  44.         '根据AutoCAD的版本判断使用的VL库类型
  45.         Select Case AcadVersion
  46.             Case Is = 15
  47.                 Set VL = .GetInterfaceObject("VL.Application.1")
  48.             Case Is >= 16
  49.                 Set VL = .GetInterfaceObject("VL.Application.16")
  50.         End Select
  51.     End With
  52.     Set VLF = VL.ActiveDocument.Functions
  53. End Sub
  54. Public Function EvalLispExpression(lispStatement As String)
  55.     '根据LISP表达式调用函数
  56.     Dim sym As Object, ret As Object, retVal
  57.     Set sym = VLF.Item("read").funcall(lispStatement)
  58.     On Error Resume Next
  59.     retVal = VLF.Item("eval").funcall(sym)
  60.     If Err Then
  61.         EvalLispExpression = ""
  62.     Else
  63.         EvalLispExpression = retVal
  64.     End If
  65.     On Error GoTo 0
  66. End Function
  67. Public Sub SetLispSymbol(symbolName As String, value)
  68.     Dim sym As Object, ret, symValue
  69.     symValue = value
  70.     Set sym = VLF.Item("read").funcall(symbolName)
  71.     ret = VLF.Item("set").funcall(sym, symValue)
  72.     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)))"
  73.     EvalLispExpression "(setq " & symbolName & "(translate-variant " & symbolName & "))"
  74.     EvalLispExpression "(setq translate-variant nil)"
  75. End Sub
  76. Public Function GetLispSymbol(symbolName As String)
  77.     Dim sym As Object, ret, symValue
  78.     symValue = value
  79.     Set sym = VLF.Item("read").funcall(symbolName)
  80.     GetLispSymbol = VLF.Item("eval").funcall(sym)
  81. End Function
  82. Public Function GetLispList(symbolName As String) As Variant
  83.     Dim sym As Object, list As Object
  84.     Dim Count, elements(), i As Long
  85.     Set sym = VLF.Item("read").funcall(symbolName)
  86.     Set list = VLF.Item("eval").funcall(sym)
  87.     Count = VLF.Item("length").funcall(list)
  88.     ReDim elements(0 To Count - 1) As Variant
  89.     For i = 0 To Count - 1
  90.         elements(i) = VLF.Item("nth").funcall(i, list)
  91.     Next
  92.     GetLispList = elements
  93. End Function
  94. Public Sub NullifySymbol(ParamArray symbolName())
  95.     Dim i As Integer
  96.     For i = LBound(symbolName) To UBound(symbolName)
  97.         EvalLispExpression "(setq " & CStr(symbolName(i)) & " nil)"
  98.     Next
  99. End Sub
  100. Private Sub Class_Terminate()
  101.     '类析构时,释放内存
  102.     Set VLF = Nothing
  103.     Set VL = Nothing
  104. End Sub


以下为测试代码:
  1. '使用直线选择集测试
  2. Sub ShowSelectLineCrips()
  3.     Dim ss As AcadSelectionSet
  4.     Dim objLine As AcadLine
  5.     Dim fType(0 To 0) As Integer
  6.     Dim fData(0 To 0) As Variant
  7.     Dim AutoSelect As Boolean
  8.     'AutoSelect = True
  9.     On Error Resume Next
  10.     ThisDrawing.SelectionSets("SelectText").Delete
  11.     Set ss = ThisDrawing.SelectionSets.Add("SelectText")
  12.     On Error GoTo 0
  13.     On Error GoTo ErrHandle
  14.     '创建过滤机制
  15.     fType(0) = 0: fData(0) = "LINE"         '直线
  16.     '选择符合条件的所有图元
  17.     If AutoSelect Then
  18.         '自动选择方式
  19.         ss.Select acSelectionSetAll, , , fType, fData
  20.     Else
  21.         '提示用户选择
  22.         ss.SelectOnScreen fType, fData
  23.     End If
  24.     If ss.Count = 0 Then Exit Sub
  25.     '显示夹点
  26.     ShowSelectionSetCrips ss
  27.     '删除数组
  28.     Erase fType: Erase fData
  29.     '删除选择集
  30.     ss.Clear: ss.Delete
  31.     Set ss = Nothing
  32.     Set objLine = Nothing
  33.     Exit Sub
  34. ErrHandle:
  35.     MsgBox Err.Description, vbCritical, "产生了以下错误:"
  36.     Err.Clear
  37. End Sub
  38. '显示选择集中对象的夹点
  39. Public Sub ShowSelectionSetCrips(ByRef ss As AcadSelectionSet)
  40.     Dim LispCode As New VLAX
  41.     Dim objEnt As AcadEntity
  42.     With LispCode
  43.         .EvalLispExpression "(setq ss (ssadd))"
  44.         For Each objEnt In ss
  45.             .EvalLispExpression "(ssadd " & _
  46.                                 "(handent " & Chr(34) & _
  47.                                 objEnt.Handle & Chr(34) & ")" & _
  48.                                 "ss" & _
  49.                                 ")"
  50.         Next
  51.         .EvalLispExpression "(sssetfirst nil ss)"
  52.         .EvalLispExpression "(setq ss nil)"
  53.     End With
  54.     Set LispCode = Nothing
  55.     'MsgBox "您选择了" & ThisDrawing.PickfirstSelectionSet.Count & "个对象"
  56. End Sub


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

在cad09中怎么实现显示选择集的夹点呢?
发表于 2018-4-14 15:34 | 显示全部楼层
你这代码有点复杂,其实选择完发个命令行就行(sssetfirst nil (ssget "P"))

点评

试了下你这个,确实效率高多了,还不用再加载VLAX,好!!!  发表于 2018-4-18 16:41
回复 支持 1 反对 0

使用道具 举报

发表于 2019-1-12 10:27 | 显示全部楼层
我这也有一版
下面是lisp函数,放在窗体上的文本框里,VL类初始化时加载
  1. (defun VBASelectionSet2ALSelectionSet(VBA_SSName / obj ss sss AL_SS) ;命名选择集转换成aut
  2.   (setq sss (vlax-get-property (vlax-get-property (vlax-get-acad-object) 'ActiveDocument) 'SelectionSets))
  3.   (setq ss (vlax-invoke-method sss 'Item VBA_SSName))
  4.   (setq AL_SS(ssadd))
  5.   (vlax-for obj ss
  6.     (ssadd (vlax-vla-object->ename obj) AL_SS)
  7.   )
  8. )

加载代码如下
  1. '加载选择集转换函数
  2. strFileName = Environ("TEMP") & "\SelectionSet.lsp"
  3. Open strFileName For Output As #5
  4.     Print #5, Form1.txtSelectionSet.Text
  5. Close #5
  6. VLFS.Item("Load").funcall strFileName
  7. Kill strFileName
复制代码

VBA实现函数如下
  1. '命名选择集显示夹点并选中
  2. Public Sub ShowPickPoints(ByVal selectionSet As Object, ByVal blnOpen As Boolean)
  3. If blnOpen = True Then
  4.     vlax.SetLispSymbol "ShowPickPoints_sset", selectionSet.Name
  5.    
  6.     vlax.EvalLispExpression "(sssetfirst nil (VBASelectionSet2ALSelectionSet ShowPickPoints_sset))"
  7.     vlax.NullifySymbol "ShowPickPoints_sset"
  8. Else
  9.     vlax.EvalLispExpression "(sssetfirst nil)"
  10. End If
  11. End Sub
 楼主| 发表于 2016-10-27 14:59 | 显示全部楼层
人工顶一下,有大神吗?
发表于 2018-1-30 16:55 | 显示全部楼层
我的2006前几天还可以实现夹点显示,现在也不行了,搞不清楚怎么回事。取不到VL.Application.16。
发表于 2018-1-30 16:56 | 显示全部楼层
到这句就出错Set VL = .GetInterfaceObject("VL.Application.16")
发表于 2018-3-1 12:16 | 显示全部楼层
在With ThisDrawing.Application的前面加一句ThisDrawing.SendCommand "(vl-load-com)" & vbCr试一下。
发表于 2018-3-5 16:40 | 显示全部楼层
vl不是16版本了

点评

还有16以后的版本吗?  发表于 2018-3-6 09:00
发表于 2018-4-24 12:30 | 显示全部楼层
你那是2006还是2016呀,高版本这个vl的com可能没有注册
发表于 2018-7-6 22:12 | 显示全部楼层
本帖最后由 jikasurvey 于 2018-7-6 22:14 编辑
wuyunpeng888 发表于 2018-4-14 15:34
你这代码有点复杂,其实选择完发个命令行就行(sssetfirst nil (ssget "P"))

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

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码,在未取得本站及作者授权的情况下,不得用于商业用途

GMT+8, 2024-3-29 23:23 , Processed in 0.195984 second(s), 31 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

快速回复 返回顶部 返回列表