|
|
发表于 2008-6-3 01:12:00
|
显示全部楼层
’在AutoCAD中编程序，写到c盘根目录下的“123.xls”Excel表格中
’使用 VBA IDE 中的“工具” “引用”菜单选项，选择 Microsoft Excel 9.0 对象模型
’水平不高，有点罗嗦，楼主可以精简下
’欢迎以后交流，QQ 42123043
Public Sub 取坐标()
’把AutoCAD中某一图层“多段线层”中的所有多段线的坐标列出来
Dim PLSet As AcadSelectionSet
Dim pl As AcadLWPolyline
Dim ExcelApp As Excel.Application
Dim ExcelSheet As Object
Dim ExcelWorkbook As Object
Dim pts As Variant
Dim NN As Integer
Dim j As Integer
Dim pn As Integer
Dim px(0 To 10000) As Double
Dim py(0 To 10000) As Double
Dim pz(0 To 10000) As Double
Dim filtertype(10) As Integer
Dim filterdata(1) As Variant
filtertype(0) = 0 ’ 选择线型
filterdata(0) = "LWPOLYLINE"
filtertype(1) = 8 ’ 图层标识，可以根据具体情况改动
filterdata(1) = "多段线层"
Set PLSet = ThisDrawing.SelectionSets.Add("pl")
PLSet.SelectOnScreen filtertype, filterdata
NN = 0
j = 0
For Each pl In PLSet
pts = pl.Coordinates
pn = (UBound(pts) + 1) / 2
For i = 0 To pn - 1
px(i + pn * j) = pts(2 * i)
py(i + pn * j) = pts(2 * i + 1)
Next i
j = j + 1
NN = NN + pn
Next pl
PLSet.Delete
Set ExcelApp = New Excel.Application
Set ExcelWorkbook = ExcelApp.Workbooks.Add
Set ExcelSheet = ExcelApp.ActiveSheet
ExcelWorkbook.SaveAs "c:\123.xls"
ExcelSheet.Cells(1, 1) = "x"
ExcelSheet.Cells(1, 2) = "y"
For i = 0 To NN - 1
ExcelSheet.Cells(i + 2, 1) = px(i)
ExcelSheet.Cells(i + 2, 2) = py(i)
Next i
End Sub |
|
置顶卡
