AutoCAD VBA绘制断面计算土方时如何建立Excel表
下面是绘制断面和土方计算部分的代码，根据代码需要建立一个内容是格式的Excel表才能正确的读取数据
Private Function area(points As Variant) As Double '多边形面积计算公式：abs(x1*y2-y1*x2+x2*y3-y2*x3...+xn*y1-yn*x1)/2
Dim l As Long
l = UBound(points) - 2
Dim i As Long
Dim s As Double
s = 0
For i = 0 To l Step 2
s = s + points(i) * points(i + 3) - points(i + 1) * points(i + 2)
Next i
s = s + points(i) * points(1) - points(i + 1) * points(0)
area = Abs(s / 2)
End Function
Sub HDM()
Dim Excel As Excel.Application
Dim ExcelSheet As Object
Dim ExcelWorkbook As Object
Dim i As Integer
Dim m As Integer
Dim kl As Double
Dim kr As Double
Dim lineobj As AcadLine
Dim klineobj As AcadLine
Dim zzPnt(0 To 2) As Double
Dim lfPnt(0 To 2) As Double
Dim lsPnt(0 To 2) As Double
Dim ltPnt(0 To 2) As Double
Dim rfPnt(0 To 2) As Double
Dim rsPnt(0 To 2) As Double
Dim rtPnt(0 To 2) As Double
Dim kPnt(0 To 2) As Double
Dim hPnt(0 To 2) As Double
Dim slPnt(0 To 2) As Double
Dim srPnt(0 To 2) As Double
Dim czPnt(0 To 2) As Double
Dim cz1Pnt(0 To 2) As Double
Dim cz2Pnt(0 To 2) As Double
Dim cz3Pnt(0 To 2) As Double
Dim xlPnt(0 To 2) As Double
Dim xrPnt(0 To 2) As Double
Dim pl As Double
Dim pr As Double
Dim spl As Double
Dim spr As Double
Dim gl1Pnt(0 To 2) As Double
Dim gl2Pnt(0 To 2) As Double
Dim gl3Pnt(0 To 2) As Double
Dim gr1Pnt(0 To 2) As Double
Dim gr2Pnt(0 To 2) As Double
Dim gr3Pnt(0 To 2) As Double
Dim gwlPnt(0 To 2) As Double
Dim gwrPnt(0 To 2) As Double
Dim bplPnt(0 To 2) As Double
Dim bprPnt(0 To 2) As Double
Dim tftl As Double
Dim tfwl As Double
Dim tftr As Double
Dim tfwr As Double
Dim tft(1 To 10000) As Double
Dim tfw(1 To 10000) As Double
Dim d(1 To 9999) As Long
Dim textObj As AcadText
Dim txtStr As String
Dim insPnt As Variant
Dim txtHeight As Double
Dim layObj As AcadLayer
Dim newLayer As AcadLayer
Set layObj = ThisDrawing.Layers.Add("标注")
Set layObj = ThisDrawing.Layers.Add("实际断面")
Set layObj = ThisDrawing.Layers.Add("设计断面")
Set layObj = ThisDrawing.Layers.Add("线性化后地面线")
Dim atTxtobj As AcadTextStyle
Set atTxtobj = ThisDrawing.ActiveTextStyle
atTxtobj.fontFile = "c:\windows\fonts\simfang.ttf"
H = InputBox("断面总个数：", , "0")
'创建Excel应用程序
On Error Resume Next
Set Excel = GetObject(, "Excel.Application")
If Err <> 0 Then
' Dim strFile As String
'strFile = ThisDrawing.Application.VBE.ActiveVBProject.FileName
Set Excel = CreateObject("Excel.Application")
End If
'打开Excel表
Dim excelname As String
excelname = InputBox("路径：", , "F:\hdm.xls")
Excel.Workbooks.Open excelname
'表格不可见
Excel.Visible = False
Worksheets("sheet1").Activate '读入坐标
i = 3
Do Until Cells(i, 1).Value = ""
tftl = 0 '画地面线
tfwl = 0
tftr = 0
tfwr = 0
d(i - 2) = Cells(i + 1, 1).Value - Cells(i, 1).Value
ltPnt(0) = 10 * (100 + Cells(i, 8).Value)
ltPnt(1) = 10 * (100 + 15 * (i - 3) + Cells(i, 9).Value)
ltPnt(2) = 0
lsPnt(0) = 10 * (100 + Cells(i, 6).Value)
lsPnt(1) = 10 * (100 + 15 * (i - 3) + Cells(i, 7).Value)
lsPnt(2) = 0
lfPnt(0) = 10 * (100 + Cells(i, 4).Value)
lfPnt(1) = 10 * (100 + 15 * (i - 3) + Cells(i, 5).Value)
lfPnt(2) = 0
zzPnt(0) = 100 * 10
zzPnt(1) = 10 * (100 + 15 * (i - 3))
zzPnt(2) = 0
rfPnt(0) = 10 * (100 + Cells(i, 10).Value)
rfPnt(1) = 10 * (100 + 15 * (i - 3) + Cells(i, 11).Value)
rfPnt(2) = 0
rsPnt(0) = 10 * (100 + Cells(i, 12).Value)
rsPnt(1) = 10 * (100 + 15 * (i - 3) + Cells(i, 13).Value)
rsPnt(2) = 0
rtPnt(0) = 10 * (100 + Cells(i, 14).Value)
rtPnt(1) = 10 * (100 + 15 * (i - 3) + Cells(i, 15).Value)
rtPnt(2) = 0
Set newLayer = ThisDrawing.Layers("实际断面")
ThisDrawing.ActiveLayer = newLayer
newLayer.color = acWhite
Set lineobj = ThisDrawing.ModelSpace.AddLine(ltPnt, lsPnt)
Set lineobj = ThisDrawing.ModelSpace.AddLine(lsPnt, lfPnt)
Set lineobj = ThisDrawing.ModelSpace.AddLine(lfPnt, zzPnt)
Set lineobj = ThisDrawing.ModelSpace.AddLine(zzPnt, rfPnt)
Set lineobj = ThisDrawing.ModelSpace.AddLine(rfPnt, rsPnt)
Set lineobj = ThisDrawing.ModelSpace.AddLine(rsPnt, rtPnt)
If Cells(i, 2) = "" Then lineobj.Delete
'画双向化后的地面线
Dim x(), y() As Double
x = Array(ltPnt(0), lsPnt(0), lfPnt(0), zzPnt(0), rfPnt(0), rsPnt(0), rtPnt(0))
y = Array(ltPnt(1), lsPnt(1), lfPnt(1), zzPnt(1), rfPnt(1), rsPnt(1), rtPnt(1))
Dim sum11, sum12 As Double
sum11 = 0
sum12 = 0
For m = 0 To 2
sum11 = sum11 + (x(m) - x(3)) * (x(m) - x(3))
sum12 = sum12 + (y(m) - y(3)) * (x(m) - x(3))
Next m
pl = sum12 / sum11
Dim sum21, sum22 As Double
sum21 = 0
sum22 = 0
For m = 4 To 6
sum21 = sum21 + (x(m) - x(3)) * (x(m) - x(3))
sum22 = sum22 + (y(m) - y(3)) * (x(m) - x(3))
Next m
pr = sum22 / sum21
xlPnt(0) = zzPnt(0) - 120
xlPnt(1) = zzPnt(1) - pl * 120
xlPnt(2) = 0
xrPnt(0) = zzPnt(0) + 120
xrPnt(1) = zzPnt(1) + pr * 120
xrPnt(2) = 0
Set newLayer = ThisDrawing.Layers("线性化后地面线")
ThisDrawing.ActiveLayer = newLayer
newLayer.color = acGreen
Set lineobj = ThisDrawing.ModelSpace.AddLine(xlPnt, zzPnt)
Set lineobj = ThisDrawing.ModelSpace.AddLine(zzPnt, xrPnt)
If Cells(i, 2) = "" Then lineobj.Delete
'画设计断面并计算土石方
Set newLayer = ThisDrawing.Layers("设计断面")
ThisDrawing.ActiveLayer = newLayer
newLayer.color = acRed
slPnt(0) = 10 * (100 - Cells(4, 17).Value / 2): slPnt(1) = 10 * (100 + 15 * (i - 3) + Cells(i, 3).Value - Cells(i, 2).Value): slPnt(2) = 0
srPnt(0) = 10 * (100 + Cells(4, 17).Value / 2): srPnt(1) = 10 * (100 + 15 * (i - 3) + Cells(i, 3).Value - Cells(i, 2).Value): srPnt(2) = 0
cz1Pnt(0) = 10 * 100 - 35: cz1Pnt(1) = 10 * (100 + 15 * (i - 3) - 3): cz1Pnt(2) = 0
cz2Pnt(0) = srPnt(0): cz2Pnt(1) = 10 * (100 + 15 * (i - 3) - 3) + 4: cz2Pnt(2) = 0
cz3Pnt(0) = srPnt(0): cz3Pnt(1) = 10 * (100 + 15 * (i - 3) - 3) - 4: cz3Pnt(2) = 0
Set lineobj = ThisDrawing.ModelSpace.AddLine(slPnt, srPnt)
--------------------编程问答-------------------- 你的错误在哪？
代码好长，另外是什么 "内容是格式"? --------------------编程问答-------------------- 不是，我的意思是：根据以上代码，可以建立一个什么样的Excel表，才能正确读取。因为我运行时出现错误“Unhandled Access Violation Reading 0x001c Exception at 33edife8h"不知道如何解决 --------------------编程问答-------------------- 不知你如何得到这代码，如果没有说明，很难猜测哪个excel文件的内容格式，就算知道格式，也不一定知道是什么意思，为什么不问作者呢？
补充：VB , VBA
