Excel to CAD 绘图技术

一缕江风

正在学，太谢谢啦。Excel----CAD，有两种方案，一种是EXCEL TO CAD 就是楼主写的，另一种是在 CAD里调用 Excel， 明经论坛绝大部分用这种方案。各有各的长处，偏工科的会习惯从CAD调用，这样处理绘图更适用。个人认为，调用Excel数据绘制相对简单的图形，还是第一种方法方便，恰恰这种方法网上介绍的比较少。
期待楼主更多的介绍

lhsh36183

905738810 发表于 2020-7-12 22:22
前面说画直线，画圆只有这一种方法，是不是感觉很单一。其实这一种方法就可以演变成多种绘图方法，我给大家 ...

谢谢分享，慢慢学习！

232670631

damn to invest,learning

905738810

一缕江风 发表于 2020-7-13 10:38
正在学，太谢谢啦。Excel----CAD，有两种方案，一种是EXCEL TO CAD 就是楼主写的，另一种是在 CAD里调用 Ex ...

两者基本没差别，会一种就会第二种了

kuangben8

一缕江风 发表于 2020-7-13 10:38
正在学，太谢谢啦。Excel----CAD，有两种方案，一种是EXCEL TO CAD 就是楼主写的，另一种是在 CAD里调用 Ex ...

可以参考这个帖子：
分享学习AutoCAD编程之VBA笔记 (期初完结！)
http://www.3dportal.cn/discuz/fo ... amp;fromuid=1739914
(出处: 三维网)

一缕江风

kuangben8 发表于 2020-7-13 11:35
可以参考这个帖子：
分享学习AutoCAD编程之VBA笔记 (期初完结！)
http://www.3dportal.cn/discuz/forum ...

谢谢啦

905738810

三，在图形中画圆弧

1. Public Sub 圆弧()
   
2.     Dim doct As Object
   
3.     Set doct = doc '引用之前函数，自己去找
   
4.     If doct Is Nothing Then Exit Sub
   
5.    
   
6.     Pi = Atn(1) * 4 'π的算法
   
7.     Dim pt(2) As Double '圆心坐标点
   
8.     Dim Rad  As Double
   
9.     Dim stAng As Double
   
10.     Dim enAng As Double
    
11.    
    
12.     pt(0) = 100: pt(1) = 100: pt(2) = 0
    
13.     Rad = 100 '圆弧的半径
    
14.     stAng = 0 '圆弧的起始角度
    
15.     enAng = Pi / 2 '圆弧的终止角度
    
16.     Set Arc = doct.ModelSpace.AddArc(pt, Rad, stAng, enAng)
    
17. End Sub
    

复制代码

代码画了四分之一的圆弧。
前三行和以前一样不解释
第四行Pi = Atn(1) * 4，因为我们知道正切45度是1，那么反正切1就是45度了，再*4就是180度，这个Atn函数返回的不是度数是弧度制
，所以就可以计算出派的值3.14。不需要精准的话也可以直接pi=3.14


赋值跳过直接解释最后一行Set Arc = doct.ModelSpace.AddArc(pt, Rad, stAng, enAng)
AddArc：绘制圆弧方法  （参数1：圆心坐标：“双精度一维3元素数组“，参数2：半径，参数3：起始角度(弧度制)，参数4：终止角度(弧度制)）
                  返回值AcadArc对象，可以对AcadArc对象进行图层，颜色，线性，线宽，等等修改或读取。
                  CADVBA中画圆弧方法只有这一种。
AddArc方法的前两个参数和画圆是一样的，重点说后两个。
在CAD中角度大小是从X方向角度为0，逆时针旋转增大的


参数3：起始角度:是圆弧起始点与原心连线的角度（注意：是弧度制）
参数4：终止角度:是圆弧末端点与原心连线的角度（注意：是弧度制）
当起始角度大于终止角度时，图形是一个大于半圆的圆弧（优弧）
当起始角度小于终止角度时，图形是一个小于半圆的圆弧（劣弧）

905738810

首先怕新人不知道弧度与角度转换关系，写了两个函数。

1. Function JtoH(ByVal j As Double) As Double '角度转弧度
   
2. Pi = Atn(1) * 4
   
3. JtoH = j / 180 * Pi
   
4. End Function
   
5. Function HtoJ(ByVal h As Double) As Double '弧度转角度
   
6. Pi = Atn(1) * 4
   
7. HtoJ = h / Pi * 180
   
8. End Function

复制代码

上回圆弧方法我又说了CADVBA中画圆弧方法只有这一种，同样的咱们还是可以变通，分享几个画圆弧自定义函数。

1. '通过圆心,起点和端点创建圆弧
   
2. Public Function AddArcCSN(ByVal ptCen As Variant, ByVal ptSt As Variant, ByVal ptNode As Variant) As AcadArc
   
3.     Dim radius As Double
   
4.     Dim stAng As Double
   
5.     Dim enAng As Double
   
6.    
   
7.     radius = Sqr((ptSt(0) - ptCen(0)) ^ 2 + (ptSt(1) - ptCen(1)) ^ 2)
   
8.     stAng = doct.Utility.AngleFromXAxis(ptCen, ptSt) '取得起始角度
   
9.     enAng = doct.Utility.AngleFromXAxis(ptCen, ptNode) '取得终止角度
   
10.     Set AddArcCSN = doct.ModelSpace.AddArc(ptCen, radius, stAng, enAng)
    
11. End Function

复制代码

1. '通过圆心,起点和圆弧的角度创建圆弧
   
2. Public Function AddArcCSA(ByVal ptCen As Variant, ByVal ptSt As Variant, ByVal angle As Double) As AcadArc
   
3.     Dim radius As Double
   
4.     Dim stAng As Double
   
5.     Dim enAng As Double
   
6.    
   
7.     radius = Sqr((ptSt(0) - ptCen(0)) ^ 2 + (ptSt(1) - ptCen(1)) ^ 2)
   
8.     stAng = doct.Utility.AngleFromXAxis(ptCen, ptSt)
   
9.     enAng = stAng + angle
   
10.     Set AddArcCSA = doct.ModelSpace.AddArc(ptCen, radius, stAng, enAng)
    
11. End Function

复制代码

1. '通过圆心,起点和弦长创建圆
   
2. Public Function AddArcCSC(ByVal ptCen As Variant, ByVal ptSt As Variant, ByVal chordLength As Double) As AcadArc
   
3.     Dim radius As Double
   
4.     Dim stAng As Double
   
5.     Dim enAng As Double
   
6.     radius = Sqr((ptSt(0) - ptCen(0)) ^ 2 + (ptSt(1) - ptCen(1)) ^ 2)
   
7.     stAng = doct.Utility.AngleFromXAxis(ptCen, ptSt)
   
8.     enAng = stAng + Atn(((chordLength / 2) / radius) / Sqr(1 - ((chordLength / 2) / radius) ^ 2)) * 2
   
9.     Set AddArcCSC = doct.ModelSpace.AddArc(ptCen, radius, stAng, enAng)
   
10. End Function

复制代码

1. '通过圆心,起点和弧长来创建圆
   
2. Public Function AddArcCSAL(ByVal ptCen As Variant, ByVal ptSt As Variant, ByVal arcLength As Double) As AcadArc
   
3.     Dim radius As Double
   
4.     Dim stAng As Double
   
5.     Dim enAng As Double
   
6.     radius = Sqr((ptSt(0) - ptCen(0)) ^ 2 + (ptSt(1) - ptCen(1)) ^ 2)
   
7.     stAng = doct.Utility.AngleFromXAxis(ptCen, ptSt)
   
8.     enAng = stAng + arcLength / radius
   
9.     Set AddArcCSAL = doct.ModelSpace.AddArc(ptCen, radius, stAng, enAng)
   
10. End Function

复制代码

1. '通过三点来创建圆弧
   
2. Public Function AddArc3P(ByVal pt1 As Variant, ByVal pt2 As Variant, ByVal pt3 As Variant) As AcadArc
   
3.     Dim ptCen As Variant
   
4.     Dim radius As Double
   
5.     Dim stAng As Double
   
6.     Dim enAng As Double
   
7.     Dim pt12(2) As Double
   
8.     Dim pt23(2) As Double
   
9.     pt12(0) = (pt1(0) + pt2(0)) / 2
   
10.     pt12(1) = (pt1(1) + pt2(1)) / 2
    
11.     pt12(2) = (pt1(2) + pt2(2)) / 2
    
12.     pt23(0) = (pt2(0) + pt3(0)) / 2
    
13.     pt23(1) = (pt2(1) + pt3(1)) / 2
    
14.     pt23(2) = (pt2(2) + pt3(2)) / 2
    
15.     Dim angle1 As Double
    
16.     Dim angle2 As Double
    
17.     angle1 = doct.Utility.AngleFromXAxis(pt1, pt2) + 1.570793
    
18.     angle2 = doct.Utility.AngleFromXAxis(pt2, pt3) + 1.570793
    
19.     Dim line12z As AcadLine
    
20.     Dim line23z As AcadLine
    
21.     Set line12z = AddLineReAL(pt12, angle1, 100) '前面自定义函数
    
22.     Set line23z = AddLineReAL(pt23, angle2, 100) '前面自定义函数
    
23.     ptCen = line12z.IntersectWith(line23z, acExtendBoth)
    
24.     line12z.Delete: line23z.Delete
    
25.     radius = Sqr((pt1(0) - ptCen(0)) ^ 2 + (pt1(1) - ptCen(1)) ^ 2)
    
26.     stAng = doct.Utility.AngleFromXAxis(ptCen, pt1)
    
27.     enAng = doct.Utility.AngleFromXAxis(ptCen, pt3)
    
28.     Set AddArc3P = doct.ModelSpace.AddArc(ptCen, radius, stAng, enAng)
    
29. End Function

复制代码

1. Dim doct As Object
   
2. Sub 调用函数画圆弧例子()
   
3.     Set doct = doc '引用之前函数，自己去找
   
4.     If doct Is Nothing Then Exit Sub
   
5.     Dim pt1(2) As Double
   
6.     Pi = Atn(1) * 4
   
7.     pt1(0) = 0: pt1(1) = 0: pt1(2) = 0
   
8.     Dim pt2(2) As Double
   
9.     pt2(0) = 100: pt2(1) = 100: pt2(2) = 0
   
10.     Dim pt3(2) As Double
    
11.     pt3(0) = -100: pt3(1) = -100: pt3(2) = 0
    
12.     AddArcCSN pt1, pt2, pt3 '通过圆心,起点和端点创建圆弧
    
13.     AddArcCSA pt1, pt2, Pi / 2 '通过圆心,起点和圆弧的角度创建圆弧
    
14.     AddArcCSC pt1, pt2, 200 '通过圆心,起点和弦长创建圆
    
15.     AddArcCSAL pt1, pt2, 500 '通过圆心,起点和弧长来创建圆
    
16.     pt1(0) = 100: pt1(1) = 200: pt1(2) = 0
    
17.     AddArc3P pt1, pt2, pt3 '通过三点来创建圆弧(三点不能在一条直线)
    
18. End Sub

复制代码

905738810

中间插个小功能，说一个激活CAD窗口问题。
我们现在可以画出图形，可是发现画出图形后CAD窗口还是在后台安稳的待着，需要我们手动切换到CAD去查看图形。
有没有什么方法，让图形画完就切换到CAD呢？
我们用API就可以解决了。

1. Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
   
2. (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
   
3. Public Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long
   
4. 
   
5. Sub 示例()
   
6. Set acadApp = GetObject(, "AutoCAD.Application")
   
7. Call jihuocad(acadApp)
   
8. End Sub
   
9. 
   
10. Sub jihuocad(acadApp)
    
11. Dim hw&, cnt&
    
12. Dim rttitle As String * 256
    
13. hw& = FindWindow(vbNullString, acadApp.Caption)
    
14. If hw& <> 0 Then
    
15.     acadApp.WindowState = acMax
    
16.     cnt& = SetForegroundWindow(hw&)
    
17. End If
    
18. End Sub
    

复制代码

在画完图形后我们调用 jihuocad 过程参数就是CAD程序对象，会神奇的发现CAD窗口置顶了，可视性大大增加。

戴维351006616

这不是CAD VBA本身的应用吗  我还以为EXCEL绘制图元呢  楼主这是在水贴