利用Excel的VBA操作CAD画图

springwillow

在逛EH论坛的时候，发现了一段代码，读取单元格数据在CAD中画矩形，其实就是调用VBA画图，觉得还是蛮有意思的，发来这里给大家开拓思路。

2. Sub DrawRectangular()
   
3.     Dim aData, i&
   
4.     Dim acadApp As Object, acadDoc As Object
   
5.     Dim dPnts#(0 To 7), dPx#, dPy#, dCenter#(0 To 2), dHeight#
   
6.    
   
7.     aData = Sheets("Sheet1").Cells(1, 1).CurrentRegion ' 读取Excel数据
   
8.    
   
9.     Set acadApp = GetObject(, "AutoCAD.Application") ' 获得已经打开的AutoCAD程序的句柄
   
10.     Set acadDoc = acadApp.ActiveDocument ' 获得AutoCAD中当前文件的句柄
    
11.    
    
12.     dPx = 0: dPy = 0: dCenter(2) = 0: dHeight = 10
    
13.     ' dPx、dPy是矩形的左下角坐标；dCenter是矩形中心点数组；dHeight是文字高度
    
14.     For i = 1 To UBound(aData)
    
15.         dPnts(0) = dPx:               dPnts(1) = dPy
    
16.         dPnts(2) = dPx:               dPnts(3) = dPy + aData(i, 2)
    
17.         dPnts(4) = dPx + aData(i, 3): dPnts(5) = dPy + aData(i, 2)
    
18.         dPnts(6) = dPx + aData(i, 3): dPnts(7) = dPy
    
19.         ' 矩形的四个顶点坐标
    
20.         With acadDoc.ModelSpace.AddLightWeightPolyline(dPnts) ' 添加多义线联结4个顶点，三段
    
21.             .Closed = True ' 多义线封闭
    
22.         End With
    
23.         dCenter(0) = dPx + aData(i, 3) / 2: dCenter(1) = dPy + aData(i, 2) / 2
    
24.         ' 计算矩形的中心点坐标
    
25.         With acadDoc.ModelSpace.AddText(aData(i, 1), dCenter, dHeight) ' 添加文字至中心点
    
26.             .Alignment = 4 ' 文字的对齐方式是 Middle
    
27.             .TextAlignmentPoint = dCenter '更改对齐点坐标，否侧字会全插到原点去
    
28.         End With
    
29.         dPx = dPx + aData(i, 3) + 10 ' 下一个矩形的左下角坐标x轴偏移10
    
30.     Next
    
31.     Set acadDoc = Nothing: Set acadApp = Nothing
    
32. End Sub
    

Sub DrawRectangular()<br />     Dim aData, i&<br />     Dim acadApp As Object, acadDoc As Object<br />     Dim dPnts#(0 To 7), dPx#, dPy#, dCenter#(0 To 2), dHeight#<br />     <br />     aData = Sheets("Sheet1").Cells(1, 1).CurrentRegion ' 读取Excel数据<br />     <br />     Set acadApp = GetObject(, "<a href="http://bbs.mjtd.com/forum-41-1.html" target="_blank" class="relatedlink">AutoCAD</a>.Application") ' 获得已经打开的AutoCAD程序的句柄<br />     Set acadDoc = acadApp.ActiveDocument ' 获得AutoCAD中当前文件的句柄<br />     <br />     dPx = 0: dPy = 0: dCenter(2) = 0: dHeight = 10<br />     ' dPx、dPy是矩形的左下角坐标；dCenter是矩形中心点数组；dHeight是文字高度<br />     For i = 1 To UBound(aData)<br />         dPnts(0) = dPx:               dPnts(1) = dPy<br />         dPnts(2) = dPx:               dPnts(3) = dPy + aData(i, 2)<br />         dPnts(4) = dPx + aData(i, 3): dPnts(5) = dPy + aData(i, 2)<br />         dPnts(6) = dPx + aData(i, 3): dPnts(7) = dPy<br />         ' 矩形的四个顶点坐标<br />         With acadDoc.ModelSpace.AddLightWeightPolyline(dPnts) ' 添加多义线联结4个顶点，三段<br />             .Closed = True ' 多义线封闭<br />         End With<br />         dCenter(0) = dPx + aData(i, 3) / 2: dCenter(1) = dPy + aData(i, 2) / 2<br />         ' 计算矩形的中心点坐标<br />         With acadDoc.ModelSpace.AddText(aData(i, 1), dCenter, dHeight) ' 添加文字至中心点<br />             .Alignment = 4 ' 文字的对齐方式是 Middle<br />             .TextAlignmentPoint = dCenter '更改对齐点坐标，否侧字会全插到原点去<br />         End With<br />         dPx = dPx + aData(i, 3) + 10 ' 下一个矩形的左下角坐标x轴偏移10<br />     Next<br />     Set acadDoc = Nothing: Set acadApp = Nothing<br /> End Sub<br />

luojie110

抢一个沙发

QQ214189912

                  谢谢分享

linyi9121