Excel to CAD 绘图技术

905738810

示例2展点示例优化
学习了选择集会过来再看展点示例

在示例中读取CAD点用到了ModelSpace集合，这个集合包含了文档中所有图形，一旦图形非常多遍历ModelSpace集合，那效率就非常低了。
这时候就可以用选择集，将有用的图形选择出来，没用的图形不选择，这样效率能提升很多很多。

优化后用 S.Select acSelectionSetAll方法选择CAD图形，并且进行过滤选择，过滤DXF组码值0."POINT"点类型，DXF组码值1001.XData扩展数据应用程序名"1"，选择完成后直接遍历选择集S
示例2优化.rar (25.57 KB, 下载次数: 45)

2020-7-28 12:12 上传

点击文件名下载附件

高度保密

905738810 发表于 2020-7-27 15:00
选择集过滤图形
过滤可以分两种，第一种是先选择后过滤，第二种是用过滤器([, FilterType] [, FilterData] ...

Sub 先选择后过滤正确版()
    Dim doct As AcadDocument
    Set doct = doc
    If doct Is Nothing Then Exit Sub
   
    Dim ss As AcadEntity
    Dim SZ() As Object
    Dim S As AcadSelectionSet
    Set S = AddSelect(doct, "SL") '创建选择集
    S.Select acSelectionSetAll '选择全部图形
    Debug.Print S.Count '打印过滤前数量
    For i = 0 To S.Count - 1 '遍历选择集
        Set ss = S.Item(i)
        If TypeName(ss) <> "IAcadLine" Then '判断图形类型，不是直线的就放到SZ数组
            ReDim Preserve SZ(i)
            Set SZ(i) = ss
        End If
    Next
    S.RemoveItems SZ '将SZ数组中的图形在选择集中移除
    Debug.Print S.Count '打印过滤后数量
End Sub

S.RemoveItems SZ '将SZ数组中的图形在选择集中移除
这句会出错，显示空对象指针。

再回去看这两句ReDim Preserve SZ(i)   
Set SZ(i) = ss
两句是下标越界，不知道是什么原因？

高度保密

905738810 发表于 2020-7-27 06:46
这些方法我已经解释了，如果你想观察可以在cad中根据pt点坐标画一个矩形，就知道选择范围了，单步运行代码 ...

多谢指点！

905738810

高度保密 发表于 2020-7-28 21:48
Sub 先选择后过滤正确版()
    Dim doct As AcadDocument
    Set doct = doc

确实有问题，多谢贴有纠正。

1. Sub 先选择后过滤正确版()
   
2.     Dim doct As AcadDocument
   
3.     Set doct = doc
   
4.     If doct Is Nothing Then Exit Sub
   
5.    
   
6.     Dim ss As AcadEntity
   
7.     Dim SZ() As Object
   
8.     Dim S As AcadSelectionSet
   
9.     Set S = AddSelect(doct, "SL") '创建选择集
   
10.     S.Select acSelectionSetAll '选择全部图形
    
11.     Debug.Print S.Count '打印过滤前数量
    
12.     ii = 0
    
13.     For i = 0 To S.Count - 1 '遍历选择集
    
14.         Set ss = S.Item(i)
    
15.         If TypeName(ss) <> "IAcadLine" Then '判断图形类型，不是直线的就放到SZ数组
    
16.             ReDim Preserve SZ(ii)
    
17.             Set SZ(ii) = ss
    
18.             ii = ii + 1
    
19.         End If
    
20.     Next
    
21.     S.RemoveItems SZ '将SZ数组中的图形在选择集中移除
    
22.     Debug.Print S.Count '打印过滤后数量
    
23. End Sub

复制代码

问题原因：在不是直线时Set SZ(i) = ss我之前依旧用 i 变量当元素索引，导致SZ数组有空值

RemoveItems方法对参数要求很严格，数组元素不能有空值，数组元素对象必须是选择集中的图元。
更改后加入新的计数变量 ii 当做索引就解决了。

905738810

常用图形修改方法
1、偏移：Offset(距离)
偏移距离可以是正值或负值，但不能等于0。如果偏移为负值，这意味着将得到更“小”的曲线 (例如，一个圆以负值偏移后的得到的圆的半径将会比原对象半径小). 如果“小”没有意义，则AutoCAD将向小的X，Y，Z WCS坐标方向偏移。如果偏移距离无效，则返回错误。对于 LightweightPolyline 和 Polyline 对象，曲线有顺时针方向和逆时针方向，对于顺时针方向，距离值为正值时为向内偏移，距离值为负值时为向外偏移。对于逆时针时刚好相反。对于自相交的多段线的偏移方向需要自己慢慢实践了。

代码示例↓↓↓

1. Sub OffsetPolyline()
   
2.     Dim doct As AcadDocument
   
3.     Set doct = doc
   
4.     If doct Is Nothing Then Exit Sub
   
5.     '创建多段线
   
6.     Dim pt(0 To 7) As Double
   
7.     pt(0) = 0:   pt(1) = 0
   
8.     pt(2) = 100:   pt(3) = 0
   
9.     pt(4) = 100:   pt(5) = 200
   
10.     pt(6) = 0:   pt(7) = 200
    
11.     Set plineObj = doct.ModelSpace.AddLightWeightPolyline(pt)
    
12.     plineObj.Closed = True
    
13. 
    
14.     ' 偏移多段线
    
15.     offsetObj = plineObj.Offset(50)
    
16. End Sub

复制代码

代码中先画一个矩形多段线，然后利用Offset向外偏移50，注意偏移后返回的对象offsetObj变量，返回值是一个数组，而不是一个对象，因为对象经过
偏移后可能有多个图形。
2、镜像：Mirror(point1, point2)，point1, point2为镜像轴所在的两点（一维三元素双精度类型数组）
代码示例↓↓↓

1. Sub MirrorPolyline()
   
2.     Dim doct As AcadDocument
   
3.     Set doct = doc
   
4.     If doct Is Nothing Then Exit Sub
   
5.     '创建多段线
   
6.     Dim pt(0 To 7) As Double
   
7.     pt(0) = 0:   pt(1) = 0
   
8.     pt(2) = 100:   pt(3) = 0
   
9.     pt(4) = 100:   pt(5) = 200
   
10.     Set plineObj = doct.ModelSpace.AddLightWeightPolyline(pt)
    
11.     plineObj.Closed = True
    
12. 
    
13.     ' 镜像多段线
    
14.     Dim point1(0 To 2)  As Double '镜像轴第一点
    
15.     Dim point2(0 To 2)  As Double '镜像轴第二点
    
16.     point1(0) = 0:   point1(1) = 0: point1(2) = 0
    
17.     point2(0) = 0:   point2(1) = 10: point2(2) = 0
    
18.     Set mirrorObj = plineObj.Mirror(point1, point2)
    
19. End Sub

复制代码

代码中画了一个多段线三角形，利用Mirror方法镜像三角形。
3、移动：Move Point1, Point2 ，Point1是移动的基准点，Point2是移动第二点，该方法没有返回值
代码示例↓↓↓

1. Sub MovePolyline()
   
2.     Dim doct As AcadDocument
   
3.     Set doct = doc
   
4.     If doct Is Nothing Then Exit Sub
   
5.     '创建多段线
   
6.     Dim pt(0 To 7) As Double
   
7.     pt(0) = 0:   pt(1) = 0
   
8.     pt(2) = 100:   pt(3) = 0
   
9.     pt(4) = 100:   pt(5) = 200
   
10.     Set plineObj = doct.ModelSpace.AddLightWeightPolyline(pt)
    
11.     plineObj.Closed = True
    
12. 
    
13.     ' 移动多段线
    
14.     Dim point1(0 To 2)  As Double '基准点
    
15.     Dim point2(0 To 2)  As Double '移动第二点
    
16.     point1(0) = 0:   point1(1) = 0: point1(2) = 0
    
17.     point2(0) = 100:   point2(1) = 0: point2(2) = 0
    
18.     plineObj.Move point1, point2
    
19. End Sub

复制代码

代码中画了一个多段线三角形，利用Move方法移动三角形。

高度保密

905738810 发表于 2020-8-1 13:00
常用图形修改方法
1、偏移：Offset(距离)
偏移距离可以是正值或负值，但不能等于0。如果偏移为负值，这意 ...

这都是新建图形然后修改它们，要是原来就在图上有的，比如一个三角形，可以捕捉后修改吗？怎么捕捉到它呢？

905738810

高度保密 发表于 2020-8-5 18:13
这都是新建图形然后修改它们，要是原来就在图上有的，比如一个三角形，可以捕捉后修改吗？怎么捕捉到它呢 ...

当然可以了，利用选择集选择图形，for each 遍历选择集取出图形，对图形进行修改
这就是我为什么先讲了选择集的原因。

905738810

4、复制单个图形：Copy无参数，该方法会将图形在原位置复制一次代码示例↓↓↓

1. Sub CopyPolyline()
   
2.     Dim doct As AcadDocument
   
3.     Set doct = doc
   
4.     If doct Is Nothing Then Exit Sub
   
5.     '创建多段线
   
6.     Dim pt(0 To 7) As Double
   
7.     pt(0) = 0:   pt(1) = 0
   
8.     pt(2) = 100:   pt(3) = 0
   
9.     pt(4) = 100:   pt(5) = 200
   
10.     Set plineObj = doct.ModelSpace.AddLightWeightPolyline(pt)
    
11.     plineObj.Closed = True
    
12. 
    
13.     ' 复制多段线
    
14.     Set CopyplineObj = plineObj.Copy
    
15. End Sub

复制代码

代码中画了一个多段线三角形，利用Copy方法在原位置复制了一个，Copy方法可以配合Move方法将复制的图形移动到其他位置。
5、复制多个图形：CopyObjects（存储对象的数组）数组下限必须是0，类型必须是Object或AcadEntity

代码示例↓↓↓

1. Sub CopyPolylineAll()
   
2.     Dim doct As AcadDocument
   
3.     Set doct = doc
   
4.     If doct Is Nothing Then Exit Sub
   
5. '定义储存图形的数组
   
6.     Dim objT(0 To 1)  As Object
   
7. '创建多段线
   
8.     Dim pt(0 To 7) As Double
   
9.     pt(0) = 0:   pt(1) = 0
   
10.     pt(2) = 100:   pt(3) = 0
    
11.     pt(4) = 100:   pt(5) = 200
    
12.     Set plineObj = doct.ModelSpace.AddLightWeightPolyline(pt)
    
13.     plineObj.Closed = True
    
14. '创建圆
    
15.     Dim centerPoint(0 To 2)  As Double
    
16.     Dim rad As Double
    
17.     centerPoint(0) = 0: centerPoint(1) = 0: centerPoint(2) = 0
    
18.     rad = 150
    
19.     Set CircleObj = doct.ModelSpace.AddCircle(centerPoint, rad)
    
20. ' 将图形放入objT数组中
    
21.     Set objT(0) = plineObj
    
22.     Set objT(1) = CircleObj
    
23. ' 复制对象并返回新对象(拷贝)的数组
    
24.     objTx = doct.CopyObjects(objT)
    
25. End Sub

复制代码

代码中画了一个多段线三角形，一个圆形，并且将图形都放入objT数组中，利用CopyObjects方法将数组中的图形原位置复制一次。
CopyObjects方法扩展：该方法可以将图形从一个CAD文档复制到另一个文档中，利用他的第二可选参数
CopyObjects（存储对象的数组,[图形文档的图形对象集合ModelSpace]）

1. Sub CopyPolylineAll_to_doc2()
   
2.     Dim doct As AcadDocument
   
3.     Set doct = doc
   
4.     If doct Is Nothing Then Exit Sub
   
5. '定义储存图形的数组
   
6.     Dim objT(0 To 1)  As Object
   
7. '创建多段线
   
8.     Dim pt(0 To 7) As Double
   
9.     pt(0) = 0:   pt(1) = 0
   
10.     pt(2) = 100:   pt(3) = 0
    
11.     pt(4) = 100:   pt(5) = 200
    
12.     Set plineObj = doct.ModelSpace.AddLightWeightPolyline(pt)
    
13.     plineObj.Closed = True
    
14. '创建圆
    
15.     Dim centerPoint(0 To 2)  As Double
    
16.     Dim rad As Double
    
17.     centerPoint(0) = 0: centerPoint(1) = 0: centerPoint(2) = 0
    
18.     rad = 150
    
19.     Set CircleObj = doct.ModelSpace.AddCircle(centerPoint, rad)
    
20. ' 将图形放入objT数组中
    
21.     Set objT(0) = plineObj
    
22.     Set objT(1) = CircleObj
    
23. ' 新建一个CAD文档
    
24.     Set ACADApp = GetObject(, "AutoCAD.Application")
    
25.     Dim doct2 As AcadDocument
    
26.     Set doct2 = ACADApp.Documents.Add
    
27. ' 复制图形到新建文档的ModelSpace集合
    
28.     objTx = doct.CopyObjects(objT, doct2.ModelSpace)
    
29. End Sub

复制代码

代码后半部分用Set doct2 = ACADApp.Documents.Add新建了一个文档doct2，用CopyObjects方法将图形复制到doct2.ModelSpace集合中。

larer

想起了画五角星的那位.

905738810

larer 发表于 2020-8-6 11:25
想起了画五角星的那位.

我感觉画五角星还挺难的&#3109;&#3178;&#3109;