乐筑天下

搜索
欢迎各位开发者和用户入驻本平台 尊重版权,从我做起,拒绝盗版,拒绝倒卖 签到、发布资源、邀请好友注册,可以获得银币 请注意保管好自己的密码,避免账户资金被盗
查看: 169|回复: 9

一个选择集的增强类,刚写好,大家提提意见

[复制链接]

72

主题

2726

帖子

9

银币

社区元老

Rank: 75Rank: 75Rank: 75

铜币
3014
发表于 2004-11-12 15:25:00 | 显示全部楼层 |阅读模式
  1. Private oSel As AcadSelectionSet
  2. Private TlsFt, TlsFd
  3. Private sName As StringPublic Sub NullFilter()
  4. '清空过滤器
  5.     TlsFt = Null
  6.     TlsFd = Null
  7. End Sub
  8. Private Function IsNull() As Boolean
  9.     If oSel Is Nothing Then
  10.         IsNull = True
  11.     ElseIf oSel.Count = 0 Then
  12.         IsNull = True
  13.     Else
  14.         IsNull = False
  15.     End If
  16.    
  17. End Function
  18. Public Sub Init(Optional ByVal Name As String = "TlsSel")
  19. '创建选择集
  20. On Error Resume Next
  21.    
  22.     NullFilter
  23.     If Not oSel Is Nothing Then oSel.Delete
  24.     sName = Name
  25.     ThisDrawing.SelectionSets(sName).Delete
  26.     Set oSel = ThisDrawing.SelectionSets.Add(sName)
  27.    
  28. End Sub
  29. Private Sub Class_Terminate()
  30. '类析构时清除选择集
  31. On Error Resume Next
  32.    
  33.     If Not oSel Is Nothing Then oSel.Delete
  34.    
  35. End Sub
  36. Public Function ToArray()
  37. '转化选择集为对象数组输出
  38. On Error Resume Next
  39.   
  40.     Dim i
  41.     Dim objs() As AcadEntity
  42.     Dim nCount As Integer
  43.    
  44.     nCount = oSel.Count - 1
  45.     ReDim objs(nCount)
  46.    
  47.     For i = 0 To nCount
  48.         Set objs(i) = oSel(i)
  49.     Next i
  50.    
  51.     ToArray = objs
  52.    
  53. End Function
  54. Public Property Get Count() As Integer
  55. '获取选择集实体个数
  56. On Error Resume Next
  57.     Count = oSel.Count
  58.    
  59. End Property
  60. Public Property Get Name() As String
  61. '获取选择集名称
  62. On Error Resume Next
  63.     Name = sName
  64.    
  65. End PropertyPublic Property Get Item(ByVal Index) As AcadEntity
  66. '获取选择集实体
  67. On Error Resume Next
  68.     Set Item = oSel(Index)
  69.    
  70. End Property
  71. Public Sub AddItems(ByVal objs)
  72. '向选择集加入实体
  73. On Error Resume Next
  74.    
  75.     If IsArray(objs) Then
  76.         oSel.AddItems objs
  77.     ElseIf IsObject(objs) Then
  78.         Dim ents(0) As AcadEntity
  79.         Set ents(0) = objs
  80.         oSel.AddItems ents
  81.     End If
  82.    
  83. End Sub
  84. Public Sub RemoveItems(ByVal objs)
  85. '在选择集中移除实体
  86. On Error Resume Next
  87.    
  88.     If IsArray(objs) Then
  89.         oSel.RemoveItems objs
  90.     ElseIf IsObject(objs) Then
  91.         Dim ents(0) As AcadEntity
  92.         Set ents(0) = objs
  93.         oSel.RemoveItems ents
  94.     End If
  95.    
  96. End Sub
  97. Public Sub Clear()
  98. '清空选择集
  99. On Error Resume Next
  100.    
  101.     Select Case sName
  102.     Case "PICKFIRST"
  103.         GetPickfirstSel
  104.     Case "CURRENT"
  105.         GetActiveSel
  106.     Case Else
  107.         Init sName
  108.     End Select
  109.    
  110.     oSel.Clear
  111.    
  112. End Sub
  113. Public Sub Update()
  114. On Error Resume Next
  115.    
  116.     oSel.Update
  117. End Sub
  118. Public Function GetSel() As AcadSelectionSet
  119. '获取选择集
  120. On Error Resume Next
  121.    
  122.     Set GetSel = oSel
  123.    
  124. End Function
  125. Public Sub GetPickfirstSel()
  126. '获取Pickfirst选择集
  127. On Error Resume Next
  128.         
  129.     NullFilter
  130.     If Not oSel Is Nothing Then oSel.Delete
  131.     sName = "PICKFIRST"
  132.     ThisDrawing.SelectionSets(sName).Delete
  133.     Set oSel = ThisDrawing.PickfirstSelectionSet
  134.    
  135. End Sub
  136. Public Sub GetActiveSel()
  137. '获取Active选择集
  138. On Error Resume Next
  139.         
  140.     NullFilter
  141.     If Not oSel Is Nothing Then oSel.Delete
  142.     sName = "CURRENT"
  143.     ThisDrawing.SelectionSets(sName).Delete
  144.     Set oSel = ThisDrawing.ActiveSelectionSet
  145.    
  146. End SubPublic Sub SetFilterType(ParamArray FilterType())
  147. '设置过滤器类型
  148. On Error Resume Next
  149.    
  150.     Dim nCount As Integer
  151.     nCount = UBound(FilterType)
  152.    
  153.     Dim ft() As Integer
  154.     ReDim ft(nCount)
  155.    
  156.     For i = 0 To nCount
  157.         ft(i) = FilterType(i)
  158.     Next i
  159.    
  160.     TlsFt = ft
  161.    
  162. End Sub
  163. Public Sub SetFilterData(ParamArray FilterData())
  164. '设置过滤器
  165. On Error Resume Next
  166.    
  167.     Dim nCount As Integer
  168.     nCount = UBound(FilterData)
  169.    
  170.     Dim fd()
  171.     ReDim fd(nCount)
  172.    
  173.     For i = 0 To nCount
  174.         fd(i) = FilterData(i)
  175.     Next i
  176.    
  177.     TlsFd = fd
  178.    
  179. End Sub
  180. Public Sub SetFilter(ParamArray Filter())
  181. '设置过滤器
  182. On Error Resume Next
  183.    
  184.     Dim i
  185.     Dim n As Integer
  186.     Dim nCount As Integer
  187.     nCount = (UBound(Filter) + 1) / 2 - 1
  188.    
  189.     Dim ft() As Integer, fd()
  190.     ReDim ft(nCount), fd(nCount)
  191.    
  192.     For i = 0 To nCount
  193.         n = i * 2
  194.         ft(i) = Filter(n)
  195.         fd(i) = Filter(n + 1)
  196.     Next i
  197.    
  198.     TlsFt = ft
  199.     TlsFd = fd
  200. End Sub
  201. Public Sub AppendFilter(ParamArray Filter())
  202.     Dim n As Integer, oCount As Integer, nCount As Integer
  203.     oCount = UBound(TlsFt)
  204.     nCount = (UBound(Filter) + 1) / 2
  205.     n = oCount + nCount
  206.     ReDim Preserve TlsFt(n), TlsFd(n)
  207.     For i = 0 To nCount - 1
  208.         n = oCount + i + 1
  209.         TlsFt(n) = Filter(i * 2)
  210.         TlsFd(n) = Filter(i * 2 + 1)
  211.     Next i
  212. End Sub
  213. Public Sub SelectObjectOnScreen()
  214. On Error Resume Next
  215.         
  216.     If IsArray(TlsFt) Then
  217.         oSel.SelectOnScreen TlsFt, TlsFd
  218.     Else
  219.         oSel.SelectOnScreen
  220.     End If
  221.    
  222. End Sub
  223. Public Sub Selectobject(ByVal Mode As AcSelect, Optional ByVal Point1, Optional ByVal Point2)
  224. On Error Resume Next
  225.         
  226.     If IsArray(TlsFt) Then
  227.         If IsMissing(Point1) Then
  228.             oSel.Select Mode, , , TlsFt, TlsFd
  229.         Else
  230.             oSel.Select Mode, Point1, Point2, TlsFt, TlsFd
  231.         End If
  232.     Else
  233.         If IsMissing(Point1) Then
  234.             oSel.Select Mode
  235.         Else
  236.             oSel.Select Mode, Point1, Point2
  237.         End If
  238.     End If
  239.    
  240. End Sub
  241. Public Sub SelectObjectAtPoint(ByVal Point)
  242. On Error Resume Next
  243.         
  244.     If IsArray(TlsFt) Then
  245.         oSel.SelectAtPoint Point, TlsFt, TlsFd
  246.     Else
  247.         oSel.SelectAtPoint Point
  248.     End If
  249.    
  250. End Sub
  251. Public Sub SelectObjectByPolygon(ByVal Mode As AcSelect, Optional ByVal Points, Optional ByVal Point2)
  252. On Error Resume Next
  253.         
  254.     If IsArray(TlsFt) Then
  255.         oSel.SelectByPolygon Mode, Points, TlsFt, TlsFd
  256.     Else
  257.         oSel.SelectByPolygon Mode, Points
  258.     End If
  259.    
  260. End Sub
  261. Public Property Let Visible(ByVal Value As Boolean)
  262. On Error Resume Next
  263.     If IsNull() Then Exit Property
  264.    
  265.     Dim i As AcadEntity
  266.     For Each i In oSel
  267.         i.Visible = Value
  268.     Next i
  269.    
  270. End PropertyPublic Property Let Layer(ByVal Value As String)
  271. On Error Resume Next
  272.     If IsNull() Then Exit Property
  273.    
  274.     Dim i As AcadEntity
  275.     For Each i In oSel
  276.         i.Layer = Value
  277.     Next i
  278.    
  279. End Property
  280. Public Property Let LineType(ByVal Value As String)
  281. On Error Resume Next
  282.     If IsNull() Then Exit Property
  283.    
  284.     Dim i As AcadEntity
  285.     For Each i In oSel
  286.         i.LineType = Value
  287.     Next i
  288.    
  289. End Property
  290. Public Property Let Color(ByVal Value As ACAD_COLOR)
  291. On Error Resume Next
  292.     If IsNull() Then Exit Property
  293.    
  294.     Dim i As AcadEntity
  295.     For Each i In oSel
  296.         i.Color = Value
  297.     Next i
  298.    
  299. End Property
  300. Public Sub Move(Optional ByVal Point1, Optional ByVal Point2)
  301. On Error Resume Next
  302.     If IsNull() Then Exit Sub
  303.    
  304.     If IsMissing(Point1) Then Point1 = CreatePoint()
  305.     If IsMissing(Point2) Then Point2 = CreatePoint()
  306.    
  307.     Dim i As AcadEntity
  308.     For Each i In oSel
  309.         i.Move Point1, Point2
  310.     Next i
  311.    
  312. End Sub
  313. Public Function Copy(Optional ByVal Point1, Optional ByVal Point2)
  314. On Error Resume Next
  315.     If IsNull() Then Exit Sub
  316.    
  317.     If IsMissing(Point1) Then Point1 = CreatePoint()
  318.     If IsMissing(Point2) Then Point2 = CreatePoint()
  319.    
  320.     Dim objs() As AcadEntity
  321.     Dim i
  322.     ReDim objs(Count - 1)
  323.    
  324.     For i = 0 To Count
  325.         Set objs(i) = oSel(i).Copy
  326.         objs(i).Move Point1, Point2
  327.     Next i
  328.    
  329.     Copy = objs
  330.    
  331. End Function
  332. Public Sub Rotate(Optional ByVal BasePoint, Optional ByVal RotationAngle As Double = 1#)
  333. On Error Resume Next
  334.     If IsNull() Then Exit Sub
  335.    
  336.     If IsMissing(BasePoint) Then BasePoint = CreatePoint()
  337.         
  338.     Dim i As AcadEntity
  339.     For Each i In oSel
  340.         i.Rotate BasePoint, RotationAngle
  341.     Next i
  342. End Sub
  343. Public Sub Rotate3D(Optional ByVal Point1, Optional ByVal Point2, Optional ByVal RotationAngle As Double = 1#)
  344. On Error Resume Next
  345.     If IsNull() Then Exit Sub
  346.    
  347.     If IsMissing(Point1) Then Point1 = CreatePoint()
  348.     If IsMissing(Point2) Then Point2 = CreatePoint()
  349.    
  350.     Dim i As AcadEntity
  351.     For Each i In oSel
  352.         i.Rotate3D Point1, Point2, RotationAngle
  353.     Next i
  354. End Sub
  355. Public Sub ScaleAll(Optional ByVal BasePoint, Optional ByVal ScaleFactor As Double = 1)
  356. On Error Resume Next
  357.     If IsNull() Then Exit Sub
  358.    
  359.     If IsMissing(BasePoint) Then BasePoint = CreatePoint()
  360.    
  361.     Dim i As AcadEntity
  362.     For Each i In oSel
  363.         i.ScaleEntity BasePoint, ScaleFactor
  364.     Next i
  365. End Sub
  366. Public Sub Mirror(Optional ByVal Point1, Optional ByVal Point2)
  367. On Error Resume Next
  368.     If IsNull() Then Exit Sub
  369.    
  370.     If IsMissing(Point1) Then Point1 = CreatePoint()
  371.     If IsMissing(Point2) Then Point2 = CreatePoint()
  372.    
  373.     Dim i As AcadEntity
  374.     For Each i In oSel
  375.         i.Mirror Point1, Point2
  376.     Next i
  377. End Sub
  378. Public Sub Mirror3D(Optional ByVal Point1, Optional ByVal Point2, Optional ByVal Point3)
  379. On Error Resume Next
  380.     If IsNull() Then Exit Sub
  381.     If IsMissing(Point1) Then Point1 = CreatePoint()
  382.     If IsMissing(Point2) Then Point2 = CreatePoint()
  383.     If IsMissing(Point3) Then Point3 = CreatePoint()
  384.    
  385.     Dim i As AcadEntity
  386.     For Each i In oSel
  387.         i.Mirror3D Point1, Point2, Point3
  388.     Next i
  389. End Sub
  390. Public Sub Highlight(Optional ByVal HighlightFlag As Boolean = True)
  391. On Error Resume Next
  392.    
  393.     Dim i As AcadEntity
  394.     For Each i In oSel
  395.         i.Highlight HighlightFlag
  396.     Next i
  397. End Sub
  398. Public Sub Delete()
  399. On Error Resume Next
  400.    
  401.     oSel.Erase
  402. End SubPublic Sub CopyObjects(Optional ByVal Owner, Optional ByVal IdPairs)
  403. On Error Resume Next
  404.     If IsNull() Then Exit Sub
  405.     If IsMissing(Owner) Then
  406.         If IsMissing(IdPairs) Then
  407.             ThisDrawing.CopyObjects ToArray
  408.         Else
  409.             ThisDrawing.CopyObjects ToArray, , IdPairs
  410.         End If
  411.     Else
  412.         If IsMissing(IdPairs) Then
  413.             ThisDrawing.CopyObjects ToArray, Owner
  414.         Else
  415.             ThisDrawing.CopyObjects ToArray, Owner, IdPairs
  416.         End If
  417.     End If
  418. End Sub
  419. Public Sub GetBoundingBox(ByRef MinPoint, ByRef MaxPoint)
  420. On Error Resume Next
  421.     Dim i
  422.     Dim d1, d2, p1, p2
  423.    
  424.     If IsNull() Then Exit Sub
  425.    
  426.     oSel(0).GetBoundingBox d1, d2
  427.    
  428.     For i = 1 To Count - 1
  429.    
  430.         oSel(i).GetBoundingBox p1, p2
  431.         
  432.         If p1(0)  d2(0) Then d2(0) = p2(0)
  433.         If p2(1) > d2(1) Then d2(1) = p2(1)
  434.         
  435.     Next i
  436.    
  437.     MinPoint = d1
  438.     MaxPoint = d2
  439.    
  440. End Sub
  441. Public Function CreatePoint(Optional ByVal X As Double = 0#, Optional ByVal Y As Double = 0#, Optional ByVal Z As Double = 0#)
  442.    
  443.     Dim pnt(2) As Double
  444.     pnt(0) = X: pnt(1) = Y: pnt(2) = Z
  445.    
  446.     CreatePoint = pnt
  447.    
  448. End Function
  449. Public Function ToBlock(Optional ByVal InsertionPoint, Optional ByVal Name As String = "*U") As String
  450. On Error GoTo ErrHandle
  451.     If IsMissing(InsertionPoint) Then InsertionPoint = CreatePoint()
  452.    
  453.     If IsNull() Then Exit Function
  454.    
  455.     Dim oBlock As AcadBlock
  456.     Set oBlock = ThisDrawing.Blocks.Add(InsertionPoint, Name)
  457.     CopyObjects oBlock
  458.    
  459.     ToBlock = oBlock.Name
  460.    
  461. ErrHandle:
  462. End Function
回复

使用道具 举报

12

主题

68

帖子

6

银币

初露锋芒

Rank: 3Rank: 3Rank: 3

铜币
116
发表于 2004-11-12 15:54:00 | 显示全部楼层
沙发,谢谢了,能介绍一下吗?
回复

使用道具 举报

31

主题

129

帖子

5

银币

后起之秀

Rank: 20Rank: 20Rank: 20Rank: 20

铜币
253
发表于 2004-11-12 16:52:00 | 显示全部楼层
可否介绍一下,有哪些功能的增强?
回复

使用道具 举报

72

主题

2726

帖子

9

银币

社区元老

Rank: 75Rank: 75Rank: 75

铜币
3014
发表于 2004-11-12 19:30:00 | 显示全部楼层
比较一下下面两段代码,功能是一样的
Sub test1()
                         Dim ss As New TlsSel
                         ss.Init
                         ss.SetFilterType 0
                         ss.SetFilterData "Line"
                         ss.SelectObjectOnScreen
End Sub
Sub test2()
On Error Resume Next
                         Dim ss As AcadSelectionSet
                         ThisDrawing.SelectionSets("TlsSel").Delete
                         Set ss = ThisDrawing.SelectionSets.Add("TlsSel")
                         Dim ft(0) As Integer, fd(0)
                         ft(0) = 0: fd(0) = "Line"
                         ss.SelectOnScreen ft, fd
                         ss.Delete
End Sub
回复

使用道具 举报

12

主题

68

帖子

6

银币

初露锋芒

Rank: 3Rank: 3Rank: 3

铜币
116
发表于 2004-11-12 20:24:00 | 显示全部楼层
收下了,仔细研究研究。简化了多。
回复

使用道具 举报

158

主题

2315

帖子

10

银币

顶梁支柱

Rank: 50Rank: 50

铜币
2951
发表于 2004-11-12 20:49:00 | 显示全部楼层
建议增加一些常用属性的修改,如颜色、线型、图层等。以前象移动、复制等功能。这也是我以前想做的。
因为AX的选择集就这一点和LISP的选择集不同,操作起来也不方便。
回复

使用道具 举报

72

主题

2726

帖子

9

银币

社区元老

Rank: 75Rank: 75Rank: 75

铜币
3014
发表于 2004-11-12 22:21:00 | 显示全部楼层

按照老大的意见已做更改,见一楼代码,大家看看还有什么要加的?
回复

使用道具 举报

72

主题

2726

帖子

9

银币

社区元老

Rank: 75Rank: 75Rank: 75

铜币
3014
发表于 2004-11-12 22:31:00 | 显示全部楼层
这是测试代码
  1. Sub test1()
  2.        Dim ss As New TlsSel
  3.        ss.Init "TlsSel1"
  4.        ss.SetFilterType 0, 8
  5.        ss.SetFilterData "Line", "0"
  6.        ss.SelectObjectOnScreen
  7.        ss.GetBoundingBox p1, p2
  8. '       OutputPoint p1
  9. '       OutputPoint p2
  10.        ss.Move p1, p2
  11. End Sub
回复

使用道具 举报

31

主题

129

帖子

5

银币

后起之秀

Rank: 20Rank: 20Rank: 20Rank: 20

铜币
253
发表于 2004-11-13 09:58:00 | 显示全部楼层
不错,有所增强
回复

使用道具 举报

14

主题

48

帖子

4

银币

初露锋芒

Rank: 3Rank: 3Rank: 3

铜币
104
发表于 2004-11-14 18:07:00 | 显示全部楼层
不错也
回复

使用道具 举报

发表回复

您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

  • 微信公众平台

  • 扫描访问手机版

  • 点击图片下载手机App

QQ|关于我们|小黑屋|乐筑天下 繁体中文

GMT+8, 2025-3-16 15:05 , Processed in 0.400970 second(s), 72 queries .

© 2020-2025 乐筑天下

联系客服 关注微信 帮助中心 下载APP 返回顶部 返回列表