乐筑天下

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

为什么有时不能把我想修剪的哪一段修剪掉

[复制链接]

12

主题

27

帖子

1

银币

初露锋芒

Rank: 3Rank: 3Rank: 3

铜币
75
发表于 2003-12-29 21:05:00 | 显示全部楼层 |阅读模式
我利用SendCommand执行trim命令时,为什么有时不能把我想修剪的哪一段修剪掉,反而会把我想保留的哪一段修剪掉。我的程序的源代码如下:(这是efan2000斑竹提供给我的)
Sub test()
    Dim EntObj1 As AcadEntity
    Dim EntObj2 As AcadEntity
    Dim pPt As Variant
    ' 提示
    ThisDrawing.Utility.Prompt "选择剪切边..." & vbCr
    ' 选择对象
    ThisDrawing.Utility.GetEntity EntObj1, pPt, "选择对象:" & vbCr
    ' 亮显
    EntObj1.Highlight True
    ThisDrawing.Utility.GetEntity EntObj2, pPt, "选择要修剪的对象:" & vbCr
    EntObj1.Highlight True
    ' 判断是否为同一对象
    If EntObj1.Handle = EntObj2.Handle Then
        ThisDrawing.Utility.Prompt "对象重复" & vbCr
        ThisDrawing.Regen acActiveViewport
        Exit Sub
    End If
    ' 执行内部Trim命令,handent 通过句柄获取Lisp中的对象(实体)名称。
    ThisDrawing.SendCommand "Trim" & vbCr & "(handent """ & EntObj1.Handle & """)" & vbCr _
        & vbCr & "(handent """ & EntObj2.Handle & """)" & vbCr & vbCr
    ' 当前视图重生成
    ThisDrawing.Regen acActiveViewport
End Sub
回复

使用道具 举报

21

主题

166

帖子

7

银币

后起之秀

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

铜币
250
发表于 2003-12-29 22:43:00 | 显示全部楼层
程序有问题!
通过点选的办法实现(程序中的pPt)。
回复

使用道具 举报

26

主题

589

帖子

10

银币

中流砥柱

Rank: 25

铜币
693
发表于 2003-12-29 23:58:00 | 显示全部楼层
确实有这问题,ACAD还判断它的位置在那一边,因而通过传递对象就不行了,使用SSGet来选择过一点的实体吧。
ThisDrawing.SendCommand "Trim" & vbCr & "(handent """ & EntObj1.Handle & """)" & vbCr _
        & vbCr & "(ssget '(" & Format(pPt(0), "0.0000") & " " & Format(pPt(1), "0.0000") & "))" & vbCr & vbCr
回复

使用道具 举报

26

主题

177

帖子

7

银币

后起之秀

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

铜币
281
发表于 2003-12-30 10:28:00 | 显示全部楼层
明总写过一个关于trim和break的程序,我原来用过,是可以的。关键在于传递被剪切的对象时要使用双元表函数。
  1. '示例Break
  2. Sub Break()
  3.     Dim Pnt As Variant
  4.     Dim entObj As AcadEntity
  5.     ThisDrawing.Utility.GetEntity entObj, Pnt, "选择图元:"
  6.     Dim Pnt2 As Variant
  7.     Pnt2 = ThisDrawing.Utility.GetPoint(, "选择点:")
  8.     Dim det As String
  9.     det = GetDoubleEntTable(entObj, Pnt)
  10.     Dim lspPnt As String
  11.     lspPnt = axPoint2lspPoint(Pnt2)
  12.     ThisDrawing.SendCommand "_break" & vbCr & det & vbCr & lspPnt & vbCr
  13. End Sub
  14. '示例Trim
  15. Sub Trim()
  16.     Dim Pnt1 As Variant
  17.     Dim entObj1 As AcadEntity
  18.     ThisDrawing.Utility.GetEntity entObj1, Pnt1, "选择图元:"
  19.     Dim det1 As String
  20.     det1 = axEnt2lspEnt(entObj1)
  21.     Dim Pnt2 As Variant
  22.     Dim entObj2 As AcadEntity
  23.     ThisDrawing.Utility.GetEntity entObj2, Pnt2, "选择被剪图元:"
  24.     Dim det2 As String
  25.     det2 = GetDoubleEntTable(entObj2, Pnt2)
  26.     ThisDrawing.SendCommand "_trim" & vbCr & det1 & vbCr & vbCr & det2 & vbCr & vbCr
  27. End Sub
  28. '转换双元表的函数
  29. Public Function GetDoubleEntTable(entObj As AcadEntity, Pnt As Variant) As String
  30.     Dim entHandle As String
  31.     entHandle = entObj.Handle
  32.     GetDoubleEntTable = "(list(handent " & Chr(34) & entHandle & Chr(34) & _
  33.                      ")(list " & Str(Pnt(0)) & Str(Pnt(1)) & Str(Pnt(2)) & "))"
  34. End Function
  35. '转换点的函数
  36. Public Function axPoint2lspPoint(Pnt As Variant) As String
  37.     axPoint2lspPoint = Pnt(0) & "," & Pnt(1) & "," & Pnt(2)
  38. End Function
  39. '转换图元函数
  40. Public Function axEnt2lspEnt(entObj As AcadEntity) As String
  41.     Dim entHandle As String
  42.     entHandle = entObj.Handle
  43.     axEnt2lspEnt = "(handent " & Chr(34) & entHandle & Chr(34) & ")"
  44. End Function
回复

使用道具 举报

12

主题

27

帖子

1

银币

初露锋芒

Rank: 3Rank: 3Rank: 3

铜币
75
发表于 2003-12-30 13:21:00 | 显示全部楼层
谢谢拉,你们真厉害
回复

使用道具 举报

12

主题

46

帖子

3

银币

初露锋芒

Rank: 3Rank: 3Rank: 3

铜币
94
发表于 2004-1-4 09:53:00 | 显示全部楼层
转换双元表的函数:
(list " & Str(Pnt(0)) & Str(Pnt(1)) & Str(Pnt(2)) & "))"
三个坐标值间应加空格,否则Pnt(1)或Pnt(2)为负会出错!
回复

使用道具 举报

发表回复

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

本版积分规则

  • 微信公众平台

  • 扫描访问手机版

  • 点击图片下载手机App

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

GMT+8, 2025-3-15 10:42 , Processed in 0.350032 second(s), 64 queries .

© 2020-2025 乐筑天下

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