Excel to CAD 绘图技术

blackttea1

学习新知识,留下脚印

yes363001640

厉害啊，cad窗体嵌入后不能拉伸。

905738810

三，在图形中画样条曲线

1. Sub Spline()
   
2.     Dim doct As Object
   
3.     Set doct = doc
   
4.     If doct Is Nothing Then Exit Sub
   
5.     Dim startpt(0 To 2) As Double '起点相切的三维矢量
   
6.     Dim endpt(0 To 2) As Double '终点相切的三维矢量
   
7.     Dim ptArr(0 To 11) As Double '拟合点
   
8.    
   
9.     startpt(0) = 1: startpt(1) = 0: startpt(2) = 0
   
10.     endpt(0) = 1: endpt(1) = 0: endpt(2) = 0
    
11.     ptArr(0) = 1: ptArr(1) = 1: ptArr(2) = 0
    
12.     ptArr(3) = 5: ptArr(4) = 5: ptArr(5) = 0
    
13.     ptArr(6) = 10: ptArr(7) = 0: ptArr(8) = 0
    
14.     ptArr(9) = 20: ptArr(10) = 5: ptArr(11) = 0
    
15.     Set splineObj = doct.ModelSpace.AddSpline(ptArr, startpt, endpt) '创建样条曲线
    
16.     '-----------------------------------------------------------------------
    
17.     '已下为控制样条曲线的属性和方法
    
18.     With splineObj
    
19.         Dim pt(0 To 2) As Double
    
20.         pt(0) = 2: pt(1) = 5: pt(2) = 0
    
21. 
    
22.         q = .GetWeight(0) '参数（索引从0开始）返回给定控制点索引的样条曲线权值。
    
23.         .SetWeight 0, 10 '参数（索引从0开始,双精度数）设置给定控制点索引的样条曲线权值。
    
24.         
    
25.         p1 = .IsPeriodic '样条曲线是否周期曲线。
    
26.         p2 = .IsPlanar '样条曲线是否二维平面。
    
27.         p3 = .IsRational '样条曲线是否为有理的。
    
28.         
    
29.         .AddFitPoint 1, pt '参数（索引从0开始,坐标数组）按给定索引位置添加拟合点到样条曲线上。
    
30.         '如果索引为负数，则点被添加到样条曲线的开始处。如果索引超出了样条曲线的拟合点数量，则点被添加到样条曲线的结束处。
    
31.         
    
32.         .DeleteFitPoint 0 '参数（索引从0开始）删除样条曲线上给定索引位置的拟合点。
    
33.         .SetFitPoint 1, pt '参数（索引从0开始,坐标数组）设置样条曲线的拟合点。
    
34.         ptn = .GetFitPoint(1) '参数（索引从0开始）返回给定索引的样条曲线拟合点
    
35.         
    
36.         J = .Degree '返回样条曲线阶数
    
37.         .ElevateOrder 10 '参数（一个大于当前阶数的正整数。最大阶数值为26）提高样条曲线阶数,一旦被提高，它就不能再降低。
    
38.         '提高阶数可以提高控制点数
    
39.         '注意:样条曲线不再拟合相切，其StartTangent（起点切向）和EndTangent(终点切向)的属性不可访问。
    
40.         '编辑样条曲线的唯一办法是通过控制点方法。
    
41. 
    
42.         .SetControlPoint 1, pt '参数（索引从0开始,坐标数组）设置样条曲线在给定索引的控制点。
    
43.         ptk = .GetControlPoint(1) '参数（索引从0开始）返回给定索引的样条曲线控制点。
    
44. 
    
45.         .PurgeFitData '清理样条曲线的拟合点，清理后拟合点不在存在，样条曲线由控制点控制。
    
46.     End With
    
47. End Sub

复制代码

创建样条曲线方法，在ModelSpace集合中AddSpline (双精度数组)
该方法有3个参数
第1参数：双精度数组，数组大小必须为3的倍数。和不优化多段线参数一样，但是创建样条曲线是三维曲线有Z轴。
第2参数：起点相切的三维矢量坐标，1维3元素双精度数组。
第3参数：终点相切的三维矢量坐标，1维3元素双精度数组。
代码后半部分是总结出的样条曲线控制方法，已做了详细注释，可以自己去测试一下具体用途。

905738810

yes363001640 发表于 2020-7-20 09:07
厉害啊，cad窗体嵌入后不能拉伸。

因为代码中我加了限制，不能控制调整边缘大小，只拖动调整中间位置调整，

可以根据你的情况自己修改，代码位置在

905738810

六、在图中画点

1. Sub AddPoint()
   
2.     Dim doct As AcadDocument
   
3.     Set doct = doc
   
4.     If doct Is Nothing Then Exit Sub
   
5.     Dim pt(0 To 2) As Double ' 定义点的坐标
   
6.     pt(0) = 5: pt(1) = 5: pt(2) = 0
   
7.     Set pointObj = doct.ModelSpace.AddPoint(pt) ' 创建点
   
8.     doct.SetVariable "PDMODE", 34 '通过系统变量设置点样式
   
9.     doct.SetVariable "PDSIZE", 100 '通过系统变量设置点大小
   
10. End Sub

复制代码

创建点用AddPoint(pt)方法，里边参数为双精度坐标数组，数组元素分别代表XYZ。
点的显示样式在CAD系统变量PDMODE中修改变量的值与点样式对照表如下：

点的显示大小在CAD系统变量PDSIZE中修改。
在vba中设置系统变量通过SetVariable 方法修改系统变量，参数1为系统变量名称，参数2为系统变量的值。
CAD画点坐标是XYZ也就是说可以画出三维坐标点，在高程展点应用中很实用。

905738810

分享一个展点示例：


示例2.rar (23.97 KB, 下载次数: 73)

2020-7-21 09:55 上传

点击文件名下载附件

解释事例中两个自定义函数

1. Function SetXDat(ByVal Obj As Object, ByVal s As String)  '写入扩展数据
   
2.     Dim DataType(0 To 1) As Integer
   
3.     Dim Data(0 To 1) As Variant
   
4.     DataType(0) = 1001: Data(0) = 1 'DataType必须是1001，Data是应用程序名
   
5.     DataType(1) = 1000: Data(1) = s
   
6.     Obj.SetXData DataType, Data ' 将xdata附加到对象
   
7. End Function
   
8. Function GetXDat(ByVal Obj As Object) As Variant '读取扩展数据
   
9.     Dim DataType As Variant
   
10.     Dim Data As Variant
    
11.     Obj.GetXData 1, DataType, Data
    
12.     GetXDat = Data
    
13. End Function
    

复制代码

SetXDatr：
作用：向图形对象写入扩展数据，可以理解为写入一个注释。
用法：SetXDatr（参数1：图形对象，参数2：想写入的字符串内容不能大于255字节）
GetXDat：
作用：取得图形SetXDatr方法写入的扩展数据
用法：GetXDat（参数1：图形对象），返回扩展数据字符串

关于XData扩展数据和Dictionaries扩展词典有很多知识点，我不打算讲解了，以此示例让大家了解一下。
用这两个自定义函数存数据已经够用了，如果贴友们确实需要深入了解，可以给我回帖。


补充内容 (2020-7-29 13:26):
利用选择集优化版在http://club.excelhome.net/forum. ... 73&pid=10423470

905738810

七、创建文字
CAD中文字分两种，单行文字AcadText和多行文字AcadMText创建方法有区别。

1. '创建单行文字
   
2. Sub Text()
   
3.     Dim doct As Object
   
4.     Set doct = doc
   
5.     If doct Is Nothing Then Exit Sub
   
6.    
   
7.     Dim objText As AcadText
   
8.     Dim text As String
   
9.     Dim insertionPoint(2) As Double
   
10.     Dim Height As Double
    
11.     text = "ExceltoCAD" & vbCrLf & "单行文字创建" '内容
    
12.     insertionPoint(0) = 10: insertionPoint(1) = 20: insertionPoint(2) = 0 '插入点
    
13.     Height = 20 '文字高度
    
14.     Set objText = doct.ModelSpace.AddText(text, insertionPoint, Height)
    
15. End Sub
    
16. '创建多行文字
    
17. Sub MText()
    
18.     Dim doct As Object
    
19.     Set doct = doc
    
20.     If doct Is Nothing Then Exit Sub
    
21.    
    
22.     Dim objMText As AcadMText
    
23.     Dim insertionPoint(2) As Double
    
24.     Dim width As Double
    
25.     Dim Text As String
    
26.     insertionPoint(0) = 10: insertionPoint(1) = 20: insertionPoint(2) = 0 '插入点
    
27.     width = 200 '文本框宽度
    
28.     Text = "ExceltoCAD" & vbCrLf & "多行文字创建" '内容
    
29.     Set objMText = doct.ModelSpace.AddMText(insertionPoint, width, Text)
    
30.    objMText.Height = 20
    
31.    
    
32. End Sub

复制代码

单行文字创建方法是AddText(文字内容，插入点，文字高度)
多行文字创建方法是AddMText(插入点，文字宽度，文字内容)

单行文字和多行文字创建的区别在于：单行文字参数中需要文字高度，多行文字参数中需要文字宽度
文字宽度就像在Excel中插入的文本框宽度类似，当文字超过宽度就会换行
多行文字创建时文字高度是CAD默认的高度，如果需要更改高度可以用Height属性，如代码objMText.Height = 20。

在代码中文字内容 text = "ExceltoCAD" & vbCrLf & "单行文字创建" 都加入了vbCrLf换行符号，但是结果出来单行文字没有换行，多行文字换行了

单行文字还有一个重要属性Alignment对齐属性，可以在插入时通过调整对齐属性达到，文字居中对齐，左对齐等等
我把对齐方法写好了函数调用就可以Alignment（单行文字对象，对齐枚举值<见代码中注释>）

1. Public Function Alignment(ByVal Textobj As AcadText, ByVal A As Integer)
   
2. 'acalignmentaligned对齐的
   
3. 'acalignmentbottomcenter底部居中对齐
   
4. 'acalignmentbottomleft底部左对齐
   
5. 'acalignmentbottomright底部右对齐
   
6. 'acalignmentcenter对齐中心
   
7. 'acalignmentfit对准配合
   
8. 'acalignmentleft左对齐
   
9. 'acalignmentmiddle中间对齐
   
10. 'acalignmentmiddlecenter中间居中对齐
    
11. 'acalignmentmiddleleft中间左对齐
    
12. 'acalignmentmiddleright中间右对齐
    
13. 'acalignmentright右对齐
    
14. 'acalignmenttopcenter顶部居中对齐
    
15. 'acalignmenttopleft顶部左对齐
    
16. 'acalignmenttopright顶部右对齐
    
17. insertionPoint = Textobj.insertionPoint
    
18. Textobj.Alignment = A
    
19. Textobj.Move Textobj.TextAlignmentPoint, insertionPoint
    
20. End Function
    

复制代码

高度保密

905738810 发表于 2020-7-23 12:13
七、创建文字
CAD中文字分两种，单行文字AcadText和多行文字AcadMText创建方法有区别。单行文 ...

这个自定义函数不会用啊！怎么调用呢？

905738810

高度保密 发表于 2020-7-24 18:13
这个自定义函数不会用啊！怎么调用呢？

参数一传递一个你创建完的单行文字对象变量，参数二传递一个枚举常量，那个注释就是枚举常量

905738810

说两个视图缩放的方法。先上代码↓↓↓

1. Sub 视图缩放()
   
2.     Dim doct As AcadDocument
   
3.     Set doct = doc
   
4.     If doct Is Nothing Then Exit Sub
   
5.    
   
6.     Dim pt1(0 To 2)  As Double
   
7.     Dim pt2(0 To 2)  As Double
   
8.     pt1(0) = 0: pt1(1) = 0: pt1(2) = 0
   
9.     pt2(0) = 100: pt2(1) = 100: pt2(2) = 0
   
10.     doct.Application.ZoomWindow pt1, pt2 '两点缩放视图
    
11. 
    
12.     doct.Application.ZoomExtents '图形范围视图
    
13. End Sub

复制代码

方法一ZoomWindow：通过给定两个对角点缩放视图，点类型和以前一样是双精度数组，这个方法经常配合选择集使用。
方法二ZoomExtents：将所有图形组成的范围界限缩放到窗口，没有参数，在绘图完成后调用此方法，可以展示绘图结果。