[求助]：cad中的text怎么转换到excel里面

xumaling

比如在cad中有一个明细表20行，5列！（或者不确定行不确定列）
怎么才能把它转换到excel中也是对应行列（还要注意边框也要对应）
那位大侠有没有办法通过vba实现啊！！

雪山飞狐(lzh)

明细表是什么形式的？
可以用TureTable试试

xumaling

问一下 turetable是什么东西啊？

lgf727

主要是CAD表格中各行各列的排列要有比较明显的规侓，这样的话可以通过判断文本的插入点从而取出行和列，然后再取出传到Excel中去

xumaling

那边有TureTable？指点一下！！！

雪山飞狐(lzh)

先试试下面的代码

2. 
   
3. Sub test3()
   
4. On Error Resume Next
   
5.     Dim ss As AcadSelectionSet
   
6.     ThisDrawing.SelectionSets("TlsSel").Delete
   
7.     Set ss = ThisDrawing.SelectionSets.Add("TlsSel")
   
8.     Dim ft(0) As Integer, fd(0)
   
9.     ft(0) = 0: fd(0) = "Line"
   
10.     ss.SelectOnScreen ft, fd
    
11.    
    
12.     Dim SLines As New Collection
    
13.     Dim HLines As New Collection
    
14.     For Each i In ss
    
15.         If IsEqual(i.Angle, 0) Or IsEqual(i.Angle, Atn(1) * 4) Then
    
16.             HLines.Add i
    
17.         ElseIf IsEqual(i.Angle, Atn(1) * 2) Or IsEqual(i.Angle, Atn(1) * 6) Then
    
18.             SLines.Add i
    
19.         End If
    
20.     Next i
    
21.    
    
22.     Dim bJudge As Boolean
    
23.    
    
24.     Dim Xs As New Collection
    
25.     For Each i In SLines
    
26.         bJudge = True
    
27.         pnt = i.StartPoint
    
28.         For j = 1 To Xs.Count
    
29.             If pnt(0) = Xs(j) Then
    
30.                 bJudge = False
    
31.                 Exit For
    
32.             ElseIf pnt(0) < Xs(j) Then
    
33.                 Xs.Add pnt(0), , j
    
34.                 bJudge = False
    
35.                 Exit For
    
36.             End If
    
37.         Next j
    
38.         If bJudge Then
    
39.             Xs.Add pnt(0)
    
40.         End If
    
41.     Next i
    
42.    
    
43.     Dim Ys As New Collection
    
44.     For Each i In HLines
    
45.         bJudge = True
    
46.         pnt = i.StartPoint
    
47.         For j = 1 To Ys.Count
    
48.             If pnt(1) = Ys(j) Then
    
49.                 bJudge = False
    
50.                 Exit For
    
51.             ElseIf pnt(1) < Ys(j) Then
    
52.                 Ys.Add pnt(1), , j
    
53.                 bJudge = False
    
54.                 Exit For
    
55.             End If
    
56.         Next j
    
57.         If bJudge Then
    
58.             Ys.Add pnt(1)
    
59.         End If
    
60.     Next i
    
61.    
    
62.     For i = 1 To Xs.Count - 1
    
63.         For j = 1 To Ys.Count - 1
    
64.             ss.Clear
    
65.             ft(0) = 0: fd(0) = "*Text"
    
66.             ss.Select acSelectionSetWindow, CreatePoint(Xs(i), Ys(j)), CreatePoint(Xs(i + 1), Ys(j + 1)), ft, fd
    
67.             MsgBox ss(0).TextString
    
68.         Next j
    
69.     Next i
    
70.    
    
71. End Sub
    
72. 
    
73. Public Function CreatePoint(Optional ByVal X As Double = 0#, Optional ByVal Y As Double = 0#, Optional ByVal Z As Double = 0#)
    
74.    
    
75.     Dim pnt(2) As Double
    
76.     pnt(0) = X: pnt(1) = Y: pnt(2) = Z
    
77.    
    
78.     CreatePoint = pnt
    
79.    
    
80. End Function
    
81. 
    
82. Function IsEqual(ByVal Value1 As Double, ByVal Value2 As Double) As Boolean
    
83. 
    
84.     IsEqual = Abs(Value1 - Value2) < 10 ^ -8
    
85.    
    
86. End Function
    
87. 
    
88. 
    

<br /> Sub test3()<br /> On Error Resume Next<br />     Dim ss As AcadSelectionSet<br />     ThisDrawing.SelectionSets("TlsSel").Delete<br />     Set ss = ThisDrawing.SelectionSets.Add("TlsSel")<br />     Dim ft(0) As Integer, fd(0)<br />     ft(0) = 0: fd(0) = "Line"<br />     ss.SelectOnScreen ft, fd<br />     <br />     Dim SLines As New Collection<br />     Dim HLines As New Collection<br />     For Each i In ss<br />         If IsEqual(i.Angle, 0) Or IsEqual(i.Angle, Atn(1) * 4) Then<br />             HLines.Add i<br />         ElseIf IsEqual(i.Angle, Atn(1) * 2) Or IsEqual(i.Angle, Atn(1) * 6) Then<br />             SLines.Add i<br />         End If<br />     Next i<br />     <br />     Dim bJudge As Boolean<br />     <br />     Dim Xs As New Collection<br />     For Each i In SLines<br />         bJudge = True<br />         pnt = i.StartPoint<br />         For j = 1 To Xs.Count<br />             If pnt(0) = Xs(j) Then<br />                 bJudge = False<br />                 Exit For<br />             ElseIf pnt(0) < Xs(j) Then<br />                 Xs.Add pnt(0), , j<br />                 bJudge = False<br />                 Exit For<br />             End If<br />         Next j<br />         If bJudge Then<br />             Xs.Add pnt(0)<br />         End If<br />     Next i<br />     <br />     Dim Ys As New Collection<br />     For Each i In HLines<br />         bJudge = True<br />         pnt = i.StartPoint<br />         For j = 1 To Ys.Count<br />             If pnt(1) = Ys(j) Then<br />                 bJudge = False<br />                 Exit For<br />             ElseIf pnt(1) < Ys(j) Then<br />                 Ys.Add pnt(1), , j<br />                 bJudge = False<br />                 Exit For<br />             End If<br />         Next j<br />         If bJudge Then<br />             Ys.Add pnt(1)<br />         End If<br />     Next i<br />     <br />     For i = 1 To Xs.Count - 1<br />         For j = 1 To Ys.Count - 1<br />             ss.Clear<br />             ft(0) = 0: fd(0) = "*Text"<br />             ss.Select acSelectionSetWindow, CreatePoint(Xs(i), Ys(j)), CreatePoint(Xs(i + 1), Ys(j + 1)), ft, fd<br />             MsgBox ss(0).TextString<br />         Next j<br />     Next i<br />     <br /> End Sub<br /> <br /> Public Function CreatePoint(Optional ByVal X As Double = 0#, Optional ByVal Y As Double = 0#, Optional ByVal Z As Double = 0#)<br />     <br />     Dim pnt(2) As Double<br />     pnt(0) = X: pnt(1) = Y: pnt(2) = Z<br />     <br />     CreatePoint = pnt<br />     <br /> End Function<br /> <br /> Function IsEqual(ByVal Value1 As Double, ByVal Value2 As Double) As Boolean<br /> <br />     IsEqual = Abs(Value1 - Value2) < 10 ^ -8<br />     <br /> End Function<br /> <br /> <br />

xumaling

我加载再autocad里面 运行筐选之后出现每一个文本内容的对话框 一系列确定之后没有反应 怎么回事啊，你的程序运行步骤是什么啊

雪山飞狐(lzh)

程序选择的是线而不是文字，

xumaling

给我一个执行的步骤好不好？或者一个例子啊 我很急啊 谢谢大侠

秦林

xumaling,你好，你试试下面程序，按你的行列名称作一下改动
Private Sub strtexcel()                                             '启动excel程序,引用microsoft execl 9.0 object libraty
Dim xlapp As Excel.Application
Dim xlbook As Excel.Workbook
Dim xlsheet As Excel.Worksheet
On Error Resume Next
Set xlapp = GetObject(, "Excel.Application")
If Err Then
   Err.Clear
   Set xlapp = CreateObject("Excel.Application")
   If Err Then
      MsgBox "不能启动excel"
      Exit Sub
   End If
End If
Set xlbook = xlapp.Workbooks.Add
Set xlsheet = xlbook.activesheet
xlapp.Visible = True
xlsheet.Cells(1, 1) = "图号"
xlsheet.Cells(1, 2) = "名称"
xlsheet.Cells(1, 3) = "数量"
Dim i As Integer
For i = 0 To UBound(a, 1)
  With ThisDrawing.ModelSpace(i)
For j = 1 To 8
    xlsheet.Cells(i + 2, j) = a(i, j)
  Next
  End With
Next
End Sub
Private Sub CommandButton1_Click()

'选择文字并给数组a(i,j)变量赋值
   TextBox6.Text = ""
   TextBox7.Text = ""
   TextBox8.Text = ""
   Me.Hide
i = i + 1
For j = 1 To 3
  Select Case j
    Case 1
      aa = "图号"
    Case 2
      aa = "名称"
    Case 3
      aa = "材料"
    Select Case j
    Case 1                  '拾取文字及插入点
     On Error Resume Next
      selecttx
     TextBox1.Text = a(i, j)
      If TextBox1.Text = "" Then
      a(i, j) = TextBox1.Text
      End If
    Case 2
     On Error Resume Next
      selecttx
      TextBox2.Text = a(i, j)
    If TextBox2.Text = "" Then
       selecttx
      If TextBox2.Text = "" Then
      a(i, j) = TextBox2.Text
      End If
     End If
    Case 3
     On Error Resume Next
      selecttx
      TextBox3.Text = a(i, j)
     If TextBox3.Text = "" Then
       selecttx
       If TextBox3.Text = "" Then
      a(i, j) = TextBox3.Text
      End If
     End If

Next
Me.Show
End Sub
Function selecttx()
ThisDrawing.Utility.GetEntity tx, pickpoint, aa:
tx.Highlight (True)
a(i, j) = tx.TextString
End Function

adisonmaster

好东西，先收下。
试了一下，看来不能满足自己的要求，只能自己编程了。

zml84

参阅：http://www.xdcad.net/forum/showthread.php?s=&threadid=630784