AutoCAD VBA自动获取Excel数据生成塔基断面图

原以为这辈子再不会写程序了，无奈，还得继续…… 1、测量原始数据、处理结果。如图：

2、原始数据录入Excel ,并整理如下格式：

3、因断面图用于设计高低柱、长短腿，在AutoCAD里面只生成A、B、C、D四个腿、以及横线路方向（E）即可。

在CADVBA程序管理器中录入以下程序段： Sub yema()

Dim xcelApp As Excel.Application Dim xcelSheet As Excel.Worksheet Dim strFile As String

strFile = ThisDrawing.Application.VBE.ActiveVBProject.FileName Set xcelApp = CreateObject(\"Excel.Application\")

xcelApp.Workbooks.Open Left$(strFile, Len(strFile) - 11) & \"test.xlsx\, ReadOnly Set xcelSheet = xcelApp.ActiveWorkbook.Sheets(1) Dim mytxt As AcadTextStyle

Set mytxt = ThisDrawing.TextStyles.Add(\"standard\") mytxt.fontFile = \"c:\\windows\\fonts\\SIMFANG.TTF\" ThisDrawing.ActiveTextStyle = mytxt

'Dim newl, newl1, xxyLine, xxxLine As AcadSpline'取消顺线路方向 Dim newl, newl1, xxyLine As AcadSpline Dim startTan(0 To 2) As Double Dim endTan(0 To 2) As Double

startTan(0) = 0: startTan(1) = 0: startTan(2) = 0 endTan(0) = 0: endTan(1) = 0: endTan(2) = 0 Dim ptArr(0 To 92) As Double Dim ptArr1(0 To 92) As Double Dim ptArr2(0 To 92) As Double 'Dim ptArr3(0 To 92) As Double

Dim i, j As Integer i = 1 j = 0

Do While i < 32

ptArr(j) = xcelSheet.Range(\"C\" & i): ptArr(j + 1) = xcelSheet.Range(\"D\" & i): ptArr(j + 2) = 0

ptArr1(j) = xcelSheet.Range(\"G\" & i): ptArr1(j + 1) = xcelSheet.Range(\"H\" & i): ptArr1(j + 2) = 0

ptArr2(j) = xcelSheet.Range(\"K\" & i): ptArr2(j + 1) = xcelSheet.Range(\"L\" & i): ptArr2(j + 2) = 0

'ptArr3(j) = xcelSheet.Range(\"O\" & i): ptArr3(j + 1) = xcelSheet.Range(\"P\" & i): ptArr3(j + 2) = 0 i = i + 1 j = j + 3 Loop

Set newl = ThisDrawing.ModelSpace.AddSpline(ptArr, startTan, endTan) Set newl1 = ThisDrawing.ModelSpace.AddSpline(ptArr1, startTan, endTan) Set xxyLine = ThisDrawing.ModelSpace.AddSpline(ptArr2, startTan, endTan) 'Set xxxLine = ThisDrawing.ModelSpace.AddSpline(ptArr3, startTan, endTan) newl.color = acRed newl1.color = acYellow xxyLine.color = acBlue 'xxxLine.color = acBlue

Dim aText, cText, bText, dText As AcadText Dim txtP(0 To 2) As Double txtP(0) = ptArr(0) + 20 txtP(1) = ptArr(1) txtP(2) = 0

Set aText = ThisDrawing.ModelSpace.AddText(\"AxtP(0) = ptArr(90) - 20 txtP(1) = ptArr(91) txtP(2) = 0

Set cText = ThisDrawing.ModelSpace.AddText(\"CxtP(0) = ptArr1(0) + 20 txtP(1) = ptArr1(1) txtP(2) = 0

Set bText = ThisDrawing.ModelSpace.AddText(\"BxtP(0) = ptArr1(90) - 20 txtP(1) = ptArr1(91) txtP(2) = 0

Set dText = ThisDrawing.ModelSpace.AddText(\"D\'画坐标

Dim xLine As AcadLine Dim yLine As AcadLine

Dim stPoint(0 To 2) As Double Dim enPoint(0 To 2) As Double

stPoint(0) = -20000: stPoint(1) = 0: stPoint(2) = 0 enPoint(0) = 20000: enPoint(1) = 0: enPoint(2) = 0

Set yLine = ThisDrawing.ModelSpace.AddLine(stPoint, enPoint) stPoint(0) = 0: stPoint(1) = -13000: stPoint(2) = 0 enPoint(0) = 0: enPoint(1) = 13000: enPoint(2) = 0

Set yLine = ThisDrawing.ModelSpace.AddLine(stPoint, enPoint) '加坐标度

ThisDrawing.SetVariable \"PDMODE\ThisDrawing.SetVariable \"PDSIZE\Dim zbPoint As AcadPoint Dim zbTxt As AcadText i = -15

Do While i < 16

stPoint(0) = i * 1000: stPoint(1) = 0: stPoint(2) = 0 Set zbPoint = ThisDrawing.ModelSpace.AddPoint(stPoint) stPoint(0) = i * 1000: stPoint(1) = -700: stPoint(2) = 0 If i < 0 Then

Set zbTxt = ThisDrawing.ModelSpace.AddText(-i, stPoint, 250) Else

Set zbTxt = ThisDrawing.ModelSpace.AddText(i, stPoint, 250) End If i = i + 1 Loop i = -6

Do While i < 7

stPoint(0) = 0: stPoint(1) = i * 2000: stPoint(2) = 0 Set zbPoint = ThisDrawing.ModelSpace.AddPoint(stPoint)

stPoint(0) = -650: stPoint(1) = i * 2000 - 100: stPoint(2) = 0 Set zbTxt = ThisDrawing.ModelSpace.AddText(i, stPoint, 250) i = i + 1 Loop

'加塔号、塔型

Dim titTxt As AcadText

stPoint(0) = 1000: stPoint(1) = -10000: stPoint(2) = 0

Set titTxt = ThisDrawing.ModelSpace.AddText(xcelSheet.Range(\"B32\") & \"(\" xcelSheet.Range(\"B33\") & \")\ThisDrawing.Application.Update ZoomAll

xcelApp.ActiveWorkbook.Close xcelApp.Workbooks.Close xcelApp.Quit End Sub

& 4、运行结果如下图（OK）：