尺寸界线修剪的问题？

laoliu09

对，DimRotated好像没有extline1point和entline2point点，不知道为什么？

laoliu09

哪岂不是用vba很难办到？看来我只能用我现在的老办法了，我的方法是：往对齐标注写扩展数据，当然是自己建的标注了，记下文本在尺寸线上或尺寸线下("up" or "down")，这样就可以修剪了，跟lisp一样，但如果文本从尺寸线上移到尺寸线下或从尺寸线下移到尺寸线上，那就出问题了，因为标注里的扩展数据没变，如果可以在移动文本的同时修改扩展数据就好了，可以用modify事件，但怎么判断文本是移到尺寸线上，还是移到尺寸线下呢？这好像有点难度！哎！学海无边啊！

mccad

2. '单选标注对象获取对齐及转角标注中的各点坐标
3. Sub FixSingleDim()
4.        Dim Ent As AcadEntity
5.        Dim Pnt As Variant
6.        Dim DimPoints As Variant
7.        '选择对象
8.        ThisDrawing.Utility.GetEntity Ent, Pnt, vbCr & "选择要要获取坐标的标注对象:"
9.        If Ent.ObjectName Like "AcDb*Dimension" Then
10.                DimPoints = GetDimLinePoint(Ent)
11.                Dim i As Integer
12.                For i = 0 To UBound(DimPoints)
13.                        Debug.Print DimPoints(i)
14.                Next
15.        End If
16. End Sub'获取对齐标注及转角标注的尺寸界线原点及标注点的函数
17. '返回格式：三组三维坐标，分别与DXF组码的13,14,10组码对应。
18. '前两个坐标对应于对象模型中的ExtLine1Point,ExtLine2Point，第三个坐标在对象模型中没有。
19. '作者：明经通道 mccad
20. Function GetDimLinePoint(Dimension As AcadDimension) As Variant
21.        '在复制标注对象前先保存当前图形中的块数量
22.        Dim BlockCount As Long
23.        BlockCount = ThisDrawing.Blocks.Count
24.        '复制需要锁定文字内容的标注对象
25.        Dim CopyDimension As AcadDimension
26.        Set CopyDimension = Dimension.Copy
27.        '检查块数量是否增加，而且新增加的块名前缀是否为"*D"
28.        Dim NewBlockCount As Long
29.        NewBlockCount = ThisDrawing.Blocks.Count
30.        If NewBlockCount = BlockCount + 1 And Left(ThisDrawing.Blocks(BlockCount).Name, 2) = "*D" Then
31.                '遍历块中的对象，取得定义的点
32.                Dim EntityInBlock As AcadEntity
33.                Dim DimPnt As Variant
34.                Dim DimPoints() As Double
35.                Dim i As Integer
36.                For Each EntityInBlock In ThisDrawing.Blocks(BlockCount)
37.                        If EntityInBlock.ObjectName = "AcDbPoint" Then
38.                                i = i + 1
39.                                DimPnt = EntityInBlock.Coordinates
40.                                ReDim Preserve DimPoints(i * 3 - 1)
41.                                DimPoints(i * 3 - 3) = DimPnt(0)
42.                                DimPoints(i * 3 - 2) = DimPnt(1)
43.                                DimPoints(i * 3 - 1) = DimPnt(2)
44.                        End If
45.                Next
46.        End If
47.        '删除复制的标注对象
48.        CopyDimension.Delete
49.        GetDimLinePoint = DimPoints
50. End Function

'单选标注对象获取对齐及转角标注中的各点坐标 Sub FixSingleDim()        Dim Ent As AcadEntity        Dim Pnt As Variant        Dim DimPoints As Variant        '选择对象        ThisDrawing.Utility.GetEntity Ent, Pnt, vbCr & "选择要要获取坐标的标注对象:"        If Ent.ObjectName Like "AcDb*Dimension" Then                DimPoints = GetDimLinePoint(Ent)                Dim i As Integer                For i = 0 To UBound(DimPoints)                        Debug.Print DimPoints(i)                Next        End If End Sub'获取对齐标注及转角标注的尺寸界线原点及标注点的函数 '返回格式：三组三维坐标，分别与DXF组码的13,14,10组码对应。 '前两个坐标对应于对象模型中的ExtLine1Point,ExtLine2Point，第三个坐标在对象模型中没有。 '作者：明经通道 mccad Function GetDimLinePoint(Dimension As AcadDimension) As Variant        '在复制标注对象前先保存当前图形中的块数量        Dim BlockCount As Long        BlockCount = ThisDrawing.Blocks.Count        '复制需要锁定文字内容的标注对象        Dim CopyDimension As AcadDimension        Set CopyDimension = Dimension.Copy        '检查块数量是否增加，而且新增加的块名前缀是否为"*D"        Dim NewBlockCount As Long        NewBlockCount = ThisDrawing.Blocks.Count        If NewBlockCount = BlockCount + 1 And Left(ThisDrawing.Blocks(BlockCount).Name, 2) = "*D" Then                '遍历块中的对象，取得定义的点                Dim EntityInBlock As AcadEntity                Dim DimPnt As Variant                Dim DimPoints() As Double                Dim i As Integer                For Each EntityInBlock In ThisDrawing.Blocks(BlockCount)                        If EntityInBlock.ObjectName = "AcDbPoint" Then                                i = i + 1                                DimPnt = EntityInBlock.Coordinates                                ReDim Preserve DimPoints(i * 3 - 1)                                DimPoints(i * 3 - 3) = DimPnt(0)                                DimPoints(i * 3 - 2) = DimPnt(1)                                DimPoints(i * 3 - 1) = DimPnt(2)                        End If                Next        End If        '删除复制的标注对象        CopyDimension.Delete        GetDimLinePoint = DimPoints End Function

laoliu09

太谢谢郑老师了，原来标注对象里还隐藏了一个标注点，我翻遍对象模型也找不到啊，这正是我一直以来最想得到的点，好了，我的修剪尺寸界线的问题可以过一段落了，现在可以编出跟lisp一样的功能了，再次感谢郑老师的指导！

liangandmi

看不懂，太深了。

 

 

欢迎光临七天E店    http://7-days.taobao.com

 

zhouyxcs

界线的修正确是麻烦的。主要是尺寸线的两端点不好读取。