乐筑天下

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

选择多义线或块引用则把通过框内线打断的程序

[复制链接]

26

主题

177

帖子

7

银币

后起之秀

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

铜币
281
发表于 2003-12-17 19:02:00 | 显示全部楼层 |阅读模式
在efan那个打断线交点的程序上改的。
只对于方形块引用和多义线有效。而且速度比较慢。
对于通过块应用的多义线,也无效。
以上不知道如何解决。望高手指点。
主程序
  1. Sub blkTrim()
  2. On Error Resume Next
  3.   Dim ent As AcadEntity
  4.   Dim sset As AcadSelectionSet
  5.   Set sset = CreateSelectionSet("sset")
  6.   Dim fType, fData As Variant
  7.   BuildFilter fType, fData, 0, "INSERT"
  8.   ThisDrawing.Utility.Prompt "选择对象,会过滤其它对象,只留下块,若直接回车,则可选择多义线。"
  9.   sset.SelectOnScreen fType, fData
  10.   If sset.Count = 0 Then
  11.     ThisDrawing.Utility.Prompt "选择对象,会过滤其它对象,只留下多义线。"
  12.     BuildFilter fType, fData, 0, "*Polyline"
  13.     sset.SelectOnScreen fType, fData
  14.     If sset.Count = 0 Then Exit Sub
  15.   End If
  16.   
  17.   For Each ent In sset
  18.     entTrimF ent
  19.   Next
  20.   
  21.   sset.Delete
  22.   
  23. End Sub
  24. Sub entTrimF(entobj As AcadEntity)
  25.     Dim SSetObj As AcadSelectionSet
  26.     Dim Pt1 As Variant
  27.     Dim Pt2 As Variant
  28.     Dim i As Integer
  29.     Dim Pt, pnt1 As Variant
  30.     Dim bPt(0 To 1) As Double
  31.    
  32.    
  33.     On Error Resume Next
  34.     '创建选择集
  35.     Set SSetObj = CreateSelectionSet("ss1")
  36.     Err.Clear
  37.     entobj.GetBoundingBox Pt1, Pt2
  38.    
  39.   '要截断2次才能保证都截断完成
  40.   For k = 0 To 1
  41.     SSetObj.Select acSelectionSetCrossing, Pt1, Pt2
  42.     '从集合中删除自身实体
  43.     ssDelete SSetObj, entobj
  44.     If SSetObj.Count = 0 Then GoTo ErrTrap
  45.         For i = 0 To SSetObj.Count - 1
  46.             '选中了自身对象时,不进行操作
  47.             If SSetObj(i).Handle  entobj.Handle Then
  48.                 Pt = entobj.IntersectWith(SSetObj(i), acExtendNone)
  49.                 If Not IsEmpty(Pt) Then
  50.                     For j = 0 To UBound(Pt) Step 3
  51.                         bPt(0) = Pt(j)
  52.                         bPt(1) = Pt(j + 1)
  53.                         ThisDrawing.SendCommand "_break" & vbCr & "(handent """ & SSetObj(i).Handle & """)" & vbCr & bPt(0) & "," & bPt(1) & vbCr & "@" & vbCr
  54.                     Next j
  55.                 End If
  56.             End If
  57.         Next i
  58.      SSetObj.Clear
  59.     Next k
  60.    
  61.     SSetObj.Select acSelectionSetWindow, Pt1, Pt2
  62.     ssDelete SSetObj, entobj
  63.     SSetObj.Erase
  64.    
  65.    
  66. ErrTrap:
  67.     SSetObj.Clear
  68.     SSetObj.Delete
  69. End Sub

引用的函数
  1. Public Sub BuildFilter(typeArray, dataArray, ParamArray gCodes())
  2.     Dim fType() As Integer, fData()
  3.     Dim index As Long, i As Long
  4.    
  5.     index = LBound(gCodes) - 1
  6.         
  7.     For i = LBound(gCodes) To UBound(gCodes) Step 2
  8.         index = index + 1
  9.         ReDim Preserve fType(0 To index)
  10.         ReDim Preserve fData(0 To index)
  11.         fType(index) = CInt(gCodes(i))
  12.         fData(index) = gCodes(i + 1)
  13.     Next
  14.     typeArray = fType: dataArray = fData
  15. End Sub
  16. Public Sub ssDelete(ss As AcadSelectionSet, ent As AcadEntity)
  17.     Dim objArray(0 To 0) As AcadEntity
  18.    
  19.     Set objArray(0) = ent
  20.     ss.RemoveItems objArray
  21. End Sub
  22. Public Function CreateSelectionSet(Optional ssName As String = "ss") As AcadSelectionSet
  23.     Dim ss As AcadSelectionSet
  24.    
  25.     On Error Resume Next
  26.     Set ss = ThisDrawing.SelectionSets(ssName)
  27.     If Err Then Set ss = ThisDrawing.SelectionSets.Add(ssName)
  28.     ss.Clear
  29.     Set CreateSelectionSet = ss
  30. End Function
回复

使用道具 举报

85

主题

1175

帖子

11

银币

顶梁支柱

Rank: 50Rank: 50

铜币
1518
发表于 2003-12-25 19:27:00 | 显示全部楼层
谢谢,先看看.....
回复

使用道具 举报

发表回复

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

本版积分规则

  • 微信公众平台

  • 扫描访问手机版

  • 点击图片下载手机App

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

GMT+8, 2025-3-15 10:46 , Processed in 0.712133 second(s), 56 queries .

© 2020-2025 乐筑天下

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