如何将CAD线段的长度输出到EXCEL中

armada

我现在有件很无聊的事情要做,就是将CAD文件中许多线段的长度写到EXCEL中


然后做其他计算,由于测量的数据太多,手工做会吐血的!!


现在请教各位高手,我应该如何做呢?


我对编程不精通请哪位高手能详细的告诉我~~

leeyeafu

对编程不精通?若想学编程，可以阅读一下名为“VBA读写EXCEL文档的一般方法”或“在VC中彻底玩转EXCEL”的帖子。


若只要现成的程序，        请发一个EXCEL样表，编程时需要知道如何填写EXCEL表格。这样的程序用VBA相对容易，若需要VLISP或ARX程序，请跟帖说明。


最后，这个工作既然对你有用，就不应该是件很无聊的事情。

armada

多谢!我想先解决燃眉之急能否先给出程序?我需要的格式很简单,只需要将CAD中的某一层的线长输入到EXCEL中去,EXCEL的格式仅需要序列号和长度,仅仅是长度也可以.公司是为了计算芯片中金线用的.

leeyeafu

2. Sub GetLenth()
3.    Dim ExcelApp As New Excel.Application
4.    Dim ExcelWkbk As Excel.Workbook
5.    Set ExcelWkbk = ExcelApp.Workbooks.Add
6.    Dim i As Integer
7.    i = 1
8.    Dim Ent As AcadEntity
9.    Dim pt1 As Variant, pt2 As Variant
10.    With ExcelWkbk.Worksheets("sheet1")
11.        For Each Ent In ThisDrawing.ModelSpace
12.            If Ent.ObjectName = "AcDbLine" Then
13.                .Range("A" & i) = i
14.                .Range("B" & i) = Ent.Length
15.                i = i + 1
16.            End If
17.        Next Ent
18.    End With
19.    ExcelApp.ActiveWorkbook.SaveAs "d:\AcadLen.xls"
20.    ExcelApp.Workbooks.Close
21.    ExcelApp.Quit
22. End Sub

Sub GetLenth()    Dim ExcelApp As New Excel.Application    Dim ExcelWkbk As Excel.Workbook    Set ExcelWkbk = ExcelApp.Workbooks.Add    Dim i As Integer    i = 1    Dim Ent As AcadEntity    Dim pt1 As Variant, pt2 As Variant    With ExcelWkbk.Worksheets("sheet1")        For Each Ent In ThisDrawing.ModelSpace            If Ent.ObjectName = "AcDbLine" Then                .Range("A" & i) = i                .Range("B" & i) = Ent.Length                i = i + 1            End If        Next Ent    End With    ExcelApp.ActiveWorkbook.SaveAs "d:\AcadLen.xls"    ExcelApp.Workbooks.Close    ExcelApp.Quit End Sub

程序未加注释。工程需引用Microsoft Excel Object Library。EXCEL保存为d:\AcadLen.xls。EXCEL文档第一列为序号，第二列为线的长度。

leeyeafu

2. Sub GetLenth()
3.    Dim ExcelApp As New Excel.Application
4.    Dim ExcelWkbk As Excel.Workbook
5.    Set ExcelWkbk = ExcelApp.Workbooks.Add
6.    Dim i As Integer
7.    i = 1
8.    Dim Sel As AcadSelectionSet
9.    On Error Resume Next
10.    Set Sel = ThisDrawing.SelectionSets.Add("ss")
11.    If Err Then
12.        Err.Clear
13.        ThisDrawing.SelectionSets.Item("ss").Delete
14.        Set Sel = ThisDrawing.SelectionSets.Add("ss")
15.    End If
16.    On Error GoTo 0
17.    Dim gpCode(0) As Integer
18.    Dim dbValue(0) As Variant
19.    gpCode(0) = 8
20.    dbValue(0) = "图层1"
21.    Sel.Select acSelectionSetAll, , , gpCode, dbValue
22.    Dim Ent As AcadEntity
23.    With ExcelWkbk.Worksheets("sheet1")
24.        For Each Ent In Sel
25.            If Ent.ObjectName = "AcDbLine" Then
26.                .Range("A" & i) = i
27.                .Range("B" & i) = Ent.Length
28.                i = i + 1
29.            End If
30.        Next Ent
31.    End With
32.    ExcelApp.ActiveWorkbook.SaveAs "d:\AcadLen.xls"
33.    ExcelApp.Workbooks.Close
34.    ExcelApp.Quit
35.    Sel.Delete
36. End Sub

Sub GetLenth()    Dim ExcelApp As New Excel.Application    Dim ExcelWkbk As Excel.Workbook    Set ExcelWkbk = ExcelApp.Workbooks.Add    Dim i As Integer    i = 1    Dim Sel As AcadSelectionSet    On Error Resume Next    Set Sel = ThisDrawing.SelectionSets.Add("ss")    If Err Then        Err.Clear        ThisDrawing.SelectionSets.Item("ss").Delete        Set Sel = ThisDrawing.SelectionSets.Add("ss")    End If    On Error GoTo 0    Dim gpCode(0) As Integer    Dim dbValue(0) As Variant    gpCode(0) = 8    dbValue(0) = "图层1"    Sel.Select acSelectionSetAll, , , gpCode, dbValue    Dim Ent As AcadEntity    With ExcelWkbk.Worksheets("sheet1")        For Each Ent In Sel            If Ent.ObjectName = "AcDbLine" Then                .Range("A" & i) = i                .Range("B" & i) = Ent.Length                i = i + 1            End If        Next Ent    End With    ExcelApp.ActiveWorkbook.SaveAs "d:\AcadLen.xls"    ExcelApp.Workbooks.Close    ExcelApp.Quit    Sel.Delete End Sub

以上程序仅保存“图层1”的线长。

armada

太感谢你了~~~~~


看来还需多学习!

水镜影

请问如果是要输入ACCESS数据库的该怎么办？

tkyjl

如果图形中包含圆弧，或样条曲线，那样的话，按照上面的方法好像不可以？

blackfire

这个太有用了，谢谢

lqss

执行的命令是什么？