Excel to CAD 绘图技术

905738810

经过多年CAD绘图经验，自己研究总结出不少VBACAD绘图方法，现在分享出来。
第一步在Excel中引用CAD的Application对象。
声明：我用的CAD为2007版本，CADVBA对版本除了前期绑定外，其他基本功能没什么区别。
但是在2008版本以上CAD的安装包不包含有VBA组件，需要自己下载。
下载地址：https://knowledge.autodesk.com/support/autocad/downloads/caas/downloads/content/download-the-microsoft-visual-basic-for-applications-module-vba.html
建议：2014版本CAD安装VBA组件时我测试很多电脑也安装不上，如果要学VBA换个版本。

1. Sub 引用CAD()
   
2. On Error Resume Next
   
3.      Set acadApp = GetObject(, "AutoCAD.Application") '如果已经打开CAD就直接引用
   
4.      If Err Then
   
5.           Err.Clear '清空错误
   
6.           Set acadApp = CreateObject("AutoCAD.Application") '如果没有打开CAD就创建
   
7.           If Err Then
   
8.                MsgBox Err.Description '错误信息
   
9.           End If
   
10.      End If
    
11. End Sub
    
12. 'AutoCAD.Application后面可以加版本号例如AutoCAD.Application.17代表只引用2007版本CAD
    
13. '在电脑装了多个CAD时建议加上版本号

复制代码

注意：引用CAD时前期和后期绑定都要做，否则容易出现BUG。
第二步打开一个图形。

1. Set doct = acadApp.documents.Open("F:\CAD.DWG") '打开一个CAD图形

复制代码

补充内容 (2020-7-15 22:51):
实例1：http://club.excelhome.net/forum. ... 73&pid=10411072

补充内容 (2020-7-23 16:58):
实例2：http://club.excelhome.net/forum. ... 73&pid=10416331

lwwy1981

做等更新。。。。

fan0001234

牛！！！！！！！！！！！！！

niko88819

学习新知识,留下脚印

kanqingwen

前排围观~~~~

905738810

CAD引用好了就讲点你们爱听的。在上节用了代码打开了一个图形，现在就在这个图形中画图。

• Set doct = acadApp.documents.Open("F:\CAD.DWG") '打开一个CAD图形
  

一，在CAD中画直线

1. Set doct = acadApp.ActiveDocument'获取当前激活的文档“可以省略”
   
2.     Dim pt1(0 To 2) As Double, pt2(0 To 2) As Double'声明两个坐标
   
3.     pt1(0) = 0: pt1(1) = 0: pt1(2) = 0
   
4.     pt2(0) = 1000: pt2(1) = 1000: pt2(2) = 0
   
5.     Set Line = doct.ModelSpace.AddLine(pt1, pt2)’画直线

复制代码

在图中以坐标(0,0,0)为起点(1000,1000,0)为端点画一条直线。
第一句获取当前激活文档对象，如果用了open打开已经获得了文档对象可以省略。
第二句声明两个数组代表坐标点，唯度必须是(0 To 2) ，类型必须是Double。
CAD中坐标点多数情况用三个元素的一唯双精度数组表示，0代表X坐标值；1代表Y坐标值；2代表Z坐标值
本帖以二维画图讲解，Z坐标均为0
第三句第四句给数组（坐标）赋值
第四句只主要的一句，重点经讲解一下
1.doct：之前取得的文档对象，类似Excel中的workbook对象，大部分操作都在这个文档中进行
2.ModelSpace：模型集合，所有模型中图形都保存在这个集合当中，所有模型中画图方法都是在ModelSpace前提下的。
3AddLine：绘制直线方法  （参数1：起点，参数2：端点）
                  返回值ACADLine对象，可以对ACADLine对象进行图层，颜色，线性，线宽，等等修改或读取。
                  CADVBA中画直线方法只有这一种

905738810

开始做一个简单的示例，利用画直线方法在CAD中逆时针画一个矩形，如图，起始点（x,y），矩形长度=a，矩形高度=b。

1. Sub huajuxing()
   
2.     JuXing 0, 0, 100, 50
   
3. End Sub
   
4. 
   
5. Function JuXing(ByVal X As Double, ByVal Y As Double, ByVal a As Double, ByVal b As Double) '画矩形函数
   
6.     Dim doct As Object
   
7.     Set doct = doc
   
8.     If doct Is Nothing Then Exit Function '判断对象是否存在
   
9.    
   
10.     Dim pt1(0 To 2) As Double, pt2(0 To 2) As Double '声明两个坐标
    
11.     pt1(2) = 0: pt2(2) = 0 'Z轴赋值0
    
12.    
    
13.     pt1(0) = X: pt1(1) = Y
    
14.     pt2(0) = X + a: pt2(1) = Y
    
15.     Set Line = doct.ModelSpace.AddLine(pt1, pt2) '第一条直线
    
16.    
    
17.     pt2(0) = X + a: pt2(1) = Y + b
    
18.     Set Line = doct.ModelSpace.AddLine(Line.EndPoint, pt2) '第二条直线
    
19.    
    
20.     pt2(0) = X: pt2(1) = Y + b
    
21.     Set Line = doct.ModelSpace.AddLine(Line.EndPoint, pt2) '第三条直线
    
22.    
    
23.     pt2(0) = X: pt2(1) = Y
    
24.     Set Line = doct.ModelSpace.AddLine(Line.EndPoint, pt2) '第四条直线
    
25.    
    
26.     doct.Application.Update '更新图形
    
27. End Function
    
28. 
    
29. Function doc() As Object '引用已经打开的CAD
    
30. On Error Resume Next
    
31.     Set acadApp = GetObject(, "AutoCAD.Application")
    
32.     If Err Then '出错就是没有打开CAD
    
33.         Err.Clear
    
34.         MsgBox "请打开CAD"
    
35.         Set doc = Nothing
    
36.     Exit Function
    
37.     End If
    
38.     Set doc = acadApp.ActiveDocument '获取当前激活的文档
    
39. End Function

复制代码

代码很简单，都是前面讲过的，不在细讲了。
只说明两个直线属性Line.EndPoint（直线端点一个三元素数组），Line.StartPoint（直线起点一个三元素数组）。

矩形特点是两条直线首位相连的所以在代码中用Set Line = doct.ModelSpace.AddLine(Line.EndPoint, pt2)
这句就表示：用上一条直线的端点坐标当做这条直线的起点坐标，这样写省去了数组赋值看起来更容易理解。

905738810

二，在图形中画圆CAD图形可以说就是圆和直线组成，所以先把主要的讲了。

1. Sub yuan()
   
2.     Dim doct As Object
   
3.     Set doct = doc'引用之前函数，自己去找
   
4.     If doct Is Nothing Then Exit Sub
   
5.    
   
6.     Dim pt(0 To 2) As Double'声明一个数组代表圆心坐标点
   
7.     pt(0) = 50
   
8.     pt(1) = 50
   
9.     pt(2) = 0
   
10.     Rad = 100'圆的半径，半径，半径，重要的事说三遍
    
11.     Set Circl = doct.ModelSpace.AddCircle(pt, Rad)'画一个圆
    
12. End Sub

复制代码

代码前面不在解释了，直接说最后一句Set Circl = doct.ModelSpace.AddCircle(pt, Rad)
中文解释：在doct文档中的ModelSpace图形集合里画一个圆，圆心为pt，半径为Rad
AddCircle：绘制圆方法  （参数1：圆心：“双精度一维3元素数组“，参数2：半径）
                  返回值AcadCircle对象，可以对AcadCircle对象进行图层，颜色，线性，线宽，等等修改或读取。
                  CADVBA中画圆方法只有这一种。

905738810

前面说画直线，画圆只有这一种方法，是不是感觉很单一。其实这一种方法就可以演变成多种绘图方法，我给大家分享出几种常见绘制直线和圆的自定义函数。
这些函数是我百度搜来稍加改动的。

1. '根据起点和相对起点的直角坐标创建直线
   
2. '（起点,x增量,y增量）
   
3. Public Function AddLineReXY(ByVal ptSt As Variant, ByVal x As Double, ByVal y As Double) As Object
   
4.     Dim ptEn(2) As Double
   
5.     ptEn(0) = ptSt(0) + x: ptEn(1) = ptSt(1) + y: ptEn(2) = 0
   
6.     Set AddLineReXY = doct.ModelSpace.AddLine(ptSt, ptEn)
   
7. End Function

复制代码

1. '根据起点和相对极坐标创建直线
   
2. '（起点,角度'弧度制',直线长度）
   
3. Public Function AddLineReAL(ByVal ptSt As Variant, ByVal angle As Double, ByVal dist As Double) As Object
   
4.     Dim ptEn(2) As Double
   
5.     ptEn(0) = ptSt(0) + dist * Cos(angle)
   
6.     ptEn(1) = ptSt(1) + dist * Sin(angle)
   
7.     ptEn(2) = ptSt(2)
   
8.     Set AddLineReAL = doct.ModelSpace.AddLine(ptSt, ptEn)
   
9. End Function

复制代码

1. '通过两点创建圆,两点为圆的直径上的两个点
   
2. '（第一点,第二点）
   
3. Public Function AddCircle2P(ByVal pt1 As Variant, pt2 As Variant) As Object
   
4.     Dim ptCen(2) As Double
   
5.     Dim radius As Double
   
6.     ptCen(0) = (pt1(0) + pt2(0)) / 2
   
7.     ptCen(1) = (pt1(1) + pt2(1)) / 2
   
8.     ptCen(2) = (pt1(2) + pt2(2)) / 2
   
9.     radius = Sqr((pt1(0) - pt2(0)) ^ 2 + (pt1(1) - pt2(1)) ^ 2) / 2
   
10.     Set AddCircle2P = doct.ModelSpace.AddCircle(ptCen, radius)
    
11. End Function

复制代码

1. '通过三点创建圆
   
2. '三点如果在一条直线上,则无法创建圆,这里我们先不考虑这种情况
   
3. '通过几何的知识来找出圆心,垂直平分线
   
4. '（第一点,第二点,第三点）
   
5. Public Function AddCircle3P(ByVal pt1 As Variant, ByVal pt2 As Variant, ByVal pt3 As Variant) As Object
   
6.     Dim ptCen As Variant
   
7.     Dim pt12(2) As Double
   
8.     Dim pt23(2) As Double
   
9.     Dim radius As Double
   
10.     '两条直线的起点坐标
    
11.     pt12(0) = (pt1(0) + pt2(0)) / 2
    
12.     pt12(1) = (pt1(1) + pt2(1)) / 2
    
13.     pt12(2) = (pt1(2) + pt2(2)) / 2
    
14.     pt23(0) = (pt2(0) + pt3(0)) / 2
    
15.     pt23(1) = (pt2(1) + pt3(1)) / 2
    
16.     pt23(2) = (pt2(2) + pt3(2)) / 2
    
17.     Dim line12, line23, line12z, line23z
    
18.     Set line12 = doct.ModelSpace.AddLine(pt1, pt2)
    
19.     Set line23 = doct.ModelSpace.AddLine(pt2, pt3)
    
20.     Dim angle1, angle2 As Double
    
21.     angle1 = line12.angle + 1.570793
    
22.     angle2 = line23.angle + 1.570793
    
23.     Set line12z = AddLineReAL(pt12, angle1, 100) '前面自定义函数
    
24.     Set line23z = AddLineReAL(pt23, angle2, 100) '前面自定义函数
    
25.     ptCen = line12z.IntersectWith(line23z, acExtendBoth) '取垂直平分线交点
    
26.     radius = Sqr((pt1(0) - ptCen(0)) ^ 2 + (pt1(1) - ptCen(1)) ^ 2)
    
27.     Set AddCircle3P = doct.ModelSpace.AddCircle(ptCen, radius)
    
28.     line12.Delete: line23.Delete: line12z.Delete: line23z.Delete
    
29. End Function

复制代码

1. Dim doct As Object
   
2. Sub 调用函数例子()
   
3.     Set doct = doc '引用之前函数，自己去找
   
4.     If doct Is Nothing Then Exit Sub
   
5.     Dim pt(2) As Double
   
6.     pt(0) = 0: pt(1) = 0: pt(2) = 0
   
7.     AddLineReXY pt, 100, 100 '根据起点和相对起点的直角坐标创建直线
   
8.     AddLineReAL pt, 3.14 / 2, 100 '根据起点和相对极坐标创建直线
   
9.     Dim pt2(2) As Double
   
10.     pt2(0) = 100: pt2(1) = 100: pt2(2) = 0
    
11.     AddCircle2P pt, pt2 '通过两点创建圆,两点为圆的直径上的两个点
    
12.     Dim pt3(2) As Double
    
13.     pt3(0) = 100: pt3(1) = 50: pt3(2) = 0
    
14.     AddCircle3P pt, pt2, pt3 '通过三点创建圆
    
15. End Sub

复制代码

不知道为什么代码粘过来就没有缩进，新人不懂，太多了我就不挨个敲空格加缩进了。
函数看不懂没关系，直接调用就好了，以后跟我的贴就会看懂了，有时间我就会更新，内容太多了。

三坛老窖

谢谢分享！