[求助]：如何得到文本的内容传到EXCEL中去？

xyzjint_cn

我经常画的图纸有许多房间名，有时想将房间名写至EXCEL文件中
只好一个个的打字（2遍了），
我想编一个程序，顺序选择图中的文本，将文本的内容一个个传到EXCEL文件的同一列的顺序行中，
不知该程序如何实现？
希大侠相助。

我是搞净化、钢结构图纸的，前一阶段钻研了一段时间LISP编程，
学会了LISP程序的基本编制，自己也编了一些自己实用的程序，对VBA编程不太了解。

如有人需净化或钢结构的一些图纸作参考的话，可与我联系。
xyzjint_cn@sina.com

efan2000

将你的要求、实现方法、样例等相关资料上传或者贴出来，介绍明白一点，大家才能根据情况来编程实现。

xyzjint_cn

我现有一平面图如图所示，
所需程序的功能为：自动(或一个个的选取文本)将图中文本为黄色的房间的房间名（如男二更、女二更等）及由程序自动根据房间名四周的墙线计算出的房间面积写入EXCEL文件的行中,

EXCEL文件如下所示：
    A          B      C     D
    房间名  面积
1  男二更   5
2  女二更   5
3   .
     .
     .

efan2000

下面是根据你的要求写的一个VBA程序，房间面积的求法我不懂，你可以自己考虑一下。

2. 
   
3.   [FONT=courier new]
   
4. Sub test()
   
5.     On Error Resume Next
   
6.     '创建选择集
   
7.     Dim SSetObj As AcadSelectionSet
   
8.     Set SSetObj = ThisDrawing.SelectionSets("Acad2Excel")
   
9.     If Err.Number <> 0 Then
   
10.         Err.Clear
    
11.         Set SSetObj = ThisDrawing.SelectionSets.Add("Acad2Excel")
    
12.     End If
    
13.     '清空选择集
    
14.     SSetObj.Clear
    
15.     '创建过过滤机制，只选择颜色为黄色的文本
    
16.     Dim fType(0 To 1) As Integer
    
17.     Dim fData(0 To 1) As Variant
    
18.     fType(0) = 0: fData(0) = "*Text"
    
19.     fType(1) = 62: fData(1) = acYellow
    
20.     SSetObj.Select acSelectionSetAll, , , fType, fData
    
21.     '如果没有选择到实体，则中断程序的运行
    
22.     If SSetObj.Count = 0 Then
    
23.         Set SSetObj = Nothing
    
24.         Exit Sub
    
25.     End If
    
26.     '启动Excel
    
27.     Dim xlApp As Object
    
28.     Set xlApp = GetObject(, "Excel.Application")
    
29.     If Err.Number <> 0 Then
    
30.         Err.Clear
    
31.         Set xlApp = CreateObject("Excel.Application")
    
32.         If Err.Number <> 0 Then
    
33.             Set SSetObj = Nothing
    
34.             MsgBox "无法启动 Excel97 或者 Excel200 !"
    
35.             Exit Sub
    
36.         End If
    
37.     End If
    
38.     '将Excel应用程序置为显示状态，默认为不显示。
    
39.     xlApp.Visible = True
    
40.     '启动一个新的Excel应用程序时，默认没有打开工作簿。
    
41.     If xlApp.Workbooks.Count = 0 Then xlApp.Workbooks.Add
    
42.     '添加一个新的工作表
    
43.     Dim xlSheet As Object
    
44.     Set xlSheet = xlApp.ActiveWorkbook.Worksheets.Add
    
45.     xlSheet.Range("B2") = "房间名"
    
46.     xlSheet.Range("C2") = "面积"
    
47.     Dim i As Integer
    
48.     For i = 0 To SSetObj.Count - 1
    
49.         xlSheet.Range("A3").Offset(i, 0) = i + 1
    
50.         xlSheet.Range("B3").Offset(i, 0) = SSetObj(i).TextString
    
51.         xlSheet.Range("C3").Offset(i, 0) = "" '这里添加房间面积
    
52.     Next
    
53.     Set SSetObj = Nothing
    
54.     Set xlSheet = Nothing
    
55.     Set xlApp = Nothing
    
56. End Sub
    
57.   [/FONT]
    

<br />   [FONT=courier new]<br /> Sub test()<br />     On Error Resume Next<br />     '创建选择集<br />     Dim SSetObj As AcadSelectionSet<br />     Set SSetObj = ThisDrawing.SelectionSets("Acad2Excel")<br />     If Err.Number <> 0 Then<br />         Err.Clear<br />         Set SSetObj = ThisDrawing.SelectionSets.Add("Acad2Excel")<br />     End If<br />     '清空选择集<br />     SSetObj.Clear<br />     '创建过过滤机制，只选择颜色为黄色的文本<br />     Dim fType(0 To 1) As Integer<br />     Dim fData(0 To 1) As Variant<br />     fType(0) = 0: fData(0) = "*Text"<br />     fType(1) = 62: fData(1) = acYellow<br />     SSetObj.Select acSelectionSetAll, , , fType, fData<br />     '如果没有选择到实体，则中断程序的运行<br />     If SSetObj.Count = 0 Then<br />         Set SSetObj = Nothing<br />         Exit Sub<br />     End If<br />     '启动Excel<br />     Dim xlApp As Object<br />     Set xlApp = GetObject(, "Excel.Application")<br />     If Err.Number <> 0 Then<br />         Err.Clear<br />         Set xlApp = CreateObject("Excel.Application")<br />         If Err.Number <> 0 Then<br />             Set SSetObj = Nothing<br />             MsgBox "无法启动 Excel97 或者 Excel200 !"<br />             Exit Sub<br />         End If<br />     End If<br />     '将Excel应用程序置为显示状态，默认为不显示。<br />     xlApp.Visible = True<br />     '启动一个新的Excel应用程序时，默认没有打开工作簿。<br />     If xlApp.Workbooks.Count = 0 Then xlApp.Workbooks.Add<br />     '添加一个新的工作表<br />     Dim xlSheet As Object<br />     Set xlSheet = xlApp.ActiveWorkbook.Worksheets.Add<br />     xlSheet.Range("B2") = "房间名"<br />     xlSheet.Range("C2") = "面积"<br />     Dim i As Integer<br />     For i = 0 To SSetObj.Count - 1<br />         xlSheet.Range("A3").Offset(i, 0) = i + 1<br />         xlSheet.Range("B3").Offset(i, 0) = SSetObj(i).TextString<br />         xlSheet.Range("C3").Offset(i, 0) = "" '这里添加房间面积<br />     Next<br />     Set SSetObj = Nothing<br />     Set xlSheet = Nothing<br />     Set xlApp = Nothing<br /> End Sub<br />   [/FONT]<br />

xyzjint_cn

因为我不用R2OOO制图而经常用R14，而我不知VBA程序如何在R14下运行，并且VBA我不太懂，略懂一些LISP编程，
所以不知该程序用LISP程序实现该如何？
谢谢版主为我解难！！！

efan2000

在VB中，用如下的代码，先获取AutoCAD的应用程序级对象，随后用一文档级的对象代替VBA中的ThisDrawing即可，以后的代码就几乎一样。

2. 
   
3.   [FONT=courier new]
   
4.     Dim acadApp As Object
   
5.     Set acadApp = GetObject(, "AutoCAD.Application")
   
6.     If Err.Number <> 0 Then
   
7.         Err.Clear
   
8.         MsgBox "请先启动 AutoCAD R14 或者 AutoAD2000、AutoCAD2002 !"
   
9.         Exit Sub
   
10.     End If
    
11.     Dim acadDoc as Object
    
12.     Set acadDoc = acadApp.ActiveDocument
    
13.   [/FONT]
    

<br />   [FONT=courier new]<br />     Dim acadApp As Object<br />     Set acadApp = GetObject(, "AutoCAD.Application")<br />     If Err.Number <> 0 Then<br />         Err.Clear<br />         MsgBox "请先启动 AutoCAD R14 或者 AutoAD2000、AutoCAD2002 !"<br />         Exit Sub<br />     End If<br />     Dim acadDoc as Object<br />     Set acadDoc = acadApp.ActiveDocument<br />   [/FONT]<br />

注意，在R14环境下，所有的对象声明只能用Object，即只支持后绑定调用。