按实体对象提取数据到Excel

兰州人

2. Sub ReadEntityData()
3.   Dim Obj As AcadEntity
4.   Dim sel As AcadSelectionSet
5.   Dim seldata(0) As Variant, selcode(0) As Integer
6.   Dim gpdata As Variant, gpcode As Variant
7.   Dim pt(0 To 2) As Double, pt1(0 To 2) As Double
8.     With ThisDrawing
9.         ret = .Utility.GetPoint(, "指定左上角：")
10.         SetRet ret, pt
11.         ret = .Utility.GetCorner(pt, "指定对角点：")
12.         SetRet ret, pt1
13.         Set sel = .SelectionSets.Add("ss")
14.         selcode(0) = 0: gpcode = selcode
15.         seldata(0) = "Line": gpdata = seldata
16.         sel.Select acSelectionSetCrossing, pt, pt1, gpcode, gpdata
17.         Debug.Print "Line ", sel.Count
18.         .SelectionSets.Item("ss").Clear
19.         'Set sel = .SelectionSets.Add("ss")
20.         selcode(0) = 0: gpcode = selcode
21.         seldata(0) = "Dimension": gpdata = seldata
22.         sel.Select acSelectionSetCrossing, pt, pt1, gpcode, gpdata
23.         Debug.Print "Dimension ", sel.Count
24.         
25.         .SelectionSets.Item("ss").Delete
26.     End With
27.    
28. End Sub
30. Private Sub SetRet(ret As Variant, pt() As Double)
31.     pt(0) = ret(0)
32.     pt(1) = ret(1)
33.     pt(2) = ret(2)
34. End Sub
36. Function xlApp() As Object
37. '  Dim xlApp As Object    ' This Line ,Not set Excel , run Excel
38.      'Dim xlsheet As Object
39.      
40.      ' 发生错误时跳到下一个语句继续执行
41.      On Error Resume Next
42.      ' 连接Excel应用程序
43.      Set xlApp = GetObject(, "Excel.Application")
44.      
45.      If Err.Number <> 0 Then
46.          Set xlApp = CreateObject("Excel.Application")
47.          xlApp.Visible = True
48.          xlApp.Workbooks.Add
49.      End If
50.      ' 返回当前活动的工作表
51. End Function
53. Sub ObjectToExcel()
54.   Set ArcXlsheet = xlApp.Sheets(1)
55.   ArcXlsheet.Name = "Arc"
56.   Set CircleXlSheet = xlApp.Sheets(2)
57.   CircleXlSheet.Name = "Circle"
58.   Set PolylineXlSheet = xlApp.Sheets(3)
59.   PolylineXlSheet.Name = "Polyline"
60.   Set LineXlsheet = xlApp.Sheets.Add
61.   LineXlsheet.Name = "Line"
62.   Set Mtextxlsheet = xlApp.Sheets.Add
63.   Mtextxlsheet.Name = "MText"
64.   Set TextXlSheet = xlApp.Sheets.Add
65.   TextXlSheet.Name = "Text"
66.   Set DimensionXlSheet = xlApp.Sheets.Add
67.   DimensionXlSheet.Name = "Dimension"
68. End Sub
69. Sub ls()
70.   Dim Obj As AcadEntity
71.   Dim sel As AcadSelectionSet, kk As AcadSelectionSet
72.   Dim seldata(0) As Variant, selcode(0) As Integer
73.   Dim gpdata As Variant, gpcode As Variant
74.   Dim pt(0 To 2) As Double, pt1(0 To 2) As Double
75.   
76.     With ThisDrawing
77.       'If Not IsNull(ThisDrawing.SelectionSets.Item("sss")) Then
78.         'ThisDrawing.SelectionSets.Item("sss").Delete
79.         Set sel = .SelectionSets.Add("sss")
80.       'End If
81.         '' Line
82.         selcode(0) = 0: gpcode = selcode
83.         seldata(0) = "Line": gpdata = seldata
84.         sel.Select acSelectionSetAll, , , gpcode, gpdata
85.         Set kk = ReadLineAttribute(sel)
86.         Debug.Print "Line ", sel.Count
87.         '''
88.         sel.Clear
89.         seldata(0) = "Dimension": gpdata = seldata
90.         sel.Select acSelectionSetAll, , , gpcode, gpdata
91.         Debug.Print "Dimension ", sel.Count
92.         ''
93.         sel.Clear
94.         seldata(0) = "LWPOLYLINE": gpdata = seldata
95.         sel.Select acSelectionSetAll, , , gpcode, gpdata
96.         Debug.Print "LWPOLYLINE ", sel.Count
97.         ''
98.         sel.Clear
99.         seldata(0) = "POLYLINE": gpdata = seldata
100.         sel.Select acSelectionSetAll, , , gpcode, gpdata
101.         Debug.Print "POLYLINE ", sel.Count
102.         '''
103.         sel.Clear
104.         seldata(0) = "Text": gpdata = seldata
105.         sel.Select acSelectionSetAll, , , gpcode, gpdata
106.         Debug.Print "Text ", sel.Count
107.         ''
108.         sel.Clear
109.         seldata(0) = "MText": gpdata = seldata
110.         sel.Select acSelectionSetAll, , , gpcode, gpdata
111.         Debug.Print "MText ", sel.Count
112.         '' Arc Data
113.         sel.Clear
114.         seldata(0) = "Arc": gpdata = seldata
115.         sel.Select acSelectionSetAll, , , gpcode, gpdata
116.         Set kk = ReadArcAttribute(sel)
117.         ''
118.         sel.Clear
119.         seldata(0) = "Circle": gpdata = seldata
120.         sel.Select acSelectionSetAll, , , gpcode, gpdata
121.         Debug.Print "Circle ", sel.Count
122.         ''
123.         sel.Clear
124.         seldata(0) = "Ellipse": gpdata = seldata
125.         sel.Select acSelectionSetAll, , , gpcode, gpdata
126.         Debug.Print "Ellipse ", sel.Count
127.         ''
128.         sel.Clear
129.         seldata(0) = "HATCH": gpdata = seldata
130.         sel.Select acSelectionSetAll, , , gpcode, gpdata
131.         Debug.Print "Hatch ", sel.Count
132.         
133.         .SelectionSets.Item("sss").Delete
134.     End With
135. End Sub
136. ' Function Line
137. Function ReadLineAttribute(InputSel As AcadSelectionSet) As AcadSelectionSet
138.   Dim ll As AcadLine
139.   Set LineXlsheet = xlApp.Sheets("Line")
140.   
141.   ii = 1
142.     With ll
143.       For jj = 0 To 2
144.         LineXlsheet.Cells(ii, jj + 1).Value = "StartPoint(" & jj & ")"
145.         LineXlsheet.Cells(ii, jj + 4).Value = "EndPoint(" & jj & ")"
146.         LineXlsheet.Cells(ii, jj + 7).Value = "Delta(" & jj & ")"
147.       Next jj
148.       LineXlsheet.Cells(ii, 10).Value = "Length"
149.       LineXlsheet.Cells(ii, 11).Value = "Layer"
150.       LineXlsheet.Cells(ii, 12).Value = "Linetype"
151.       LineXlsheet.Cells(ii, 13).Value = "LinetypeScale"
152.       LineXlsheet.Cells(ii, 14).Value = "Lineweight"
153.       LineXlsheet.Cells(ii, 15).Value = "Color"
154.     End With
155.   
156.   
157.   ii = 2
158.   For Each ll In InputSel
159.     With ll
160.       For jj = 0 To 2
161.         LineXlsheet.Cells(ii, jj + 1).Value = Round(.StartPoint(jj), 2)
162.         LineXlsheet.Cells(ii, jj + 4).Value = Round(.EndPoint(jj), 2)
163.         LineXlsheet.Cells(ii, jj + 7).Value = Round(.Delta(jj), 2)
164.       Next jj
165.       LineXlsheet.Cells(ii, 10).Value = .Length
166.       LineXlsheet.Cells(ii, 11).Value = .Layer
167.       LineXlsheet.Cells(ii, 12).Value = .Linetype
168.       LineXlsheet.Cells(ii, 13).Value = .LinetypeScale
169.       LineXlsheet.Cells(ii, 14).Value = .Lineweight
170.       LineXlsheet.Cells(ii, 15).Value = .color
171.     End With
172.     ii = ii + 1
173.   Next ll
174. End Function
175. '''Function Arc
176. Function ReadArcAttribute(InputSel As AcadSelectionSet) As AcadSelectionSet
177.   Dim Aa As AcadArc
178.   Set ArcXlsheet = xlApp.Sheets("Arc")
179.   
180.   ii = 1
181.     With Aa
182.       For jj = 0 To 2
183.         ArcXlsheet.Cells(ii, jj + 1).Value = "Center(" & jj & ")"
184.         ArcXlsheet.Cells(ii, jj + 4).Value = "StartPoint(" & jj & ")"
185.         ArcXlsheet.Cells(ii, jj + 7).Value = "EndPoint(" & jj & ")"
186.         
187.       Next jj
188.       ArcXlsheet.Cells(ii, 10).Value = "StartAngle"
189.       ArcXlsheet.Cells(ii, 11).Value = "EndAngle"
190.       ArcXlsheet.Cells(ii, 12).Value = "TotalAngle"
191.       ArcXlsheet.Cells(ii, 13).Value = "Radius"
192.       ArcXlsheet.Cells(ii, 14).Value = "ArcLength"
193.       ArcXlsheet.Cells(ii, 15).Value = "Area"
194.       ArcXlsheet.Cells(ii, 16).Value = "Layer"
195.       ArcXlsheet.Cells(ii, 17).Value = "Linetype"
196.       ArcXlsheet.Cells(ii, 18).Value = "LinetypeScale"
197.       ArcXlsheet.Cells(ii, 19).Value = "Lineweight"
198.       ArcXlsheet.Cells(ii, 20).Value = "color"
199.     End With
200.   
201.   
202.   ii = 2
203.   For Each Aa In InputSel
204.     With Aa
205.       For jj = 0 To 2
206.         ArcXlsheet.Cells(ii, jj + 7).Value = Round(.Center(jj), 2)
207.         ArcXlsheet.Cells(ii, jj + 1).Value = Round(.StartPoint(jj), 2)
208.         ArcXlsheet.Cells(ii, jj + 4).Value = Round(.EndPoint(jj), 2)
209.         
210.       Next jj
211.       
212.       ArcXlsheet.Cells(ii, 10).Value = .StartAngle
213.       ArcXlsheet.Cells(ii, 11).Value = .EndAngle
214.       ArcXlsheet.Cells(ii, 12).Value = .TotalAngle
215.       ArcXlsheet.Cells(ii, 13).Value = .Radius
216.       ArcXlsheet.Cells(ii, 14).Value = .ArcLength
217.       ArcXlsheet.Cells(ii, 15).Value = .Area
218.       ArcXlsheet.Cells(ii, 16).Value = .Layer
219.       ArcXlsheet.Cells(ii, 17).Value = .Linetype
220.       ArcXlsheet.Cells(ii, 18).Value = .LinetypeScale
221.       ArcXlsheet.Cells(ii, 19).Value = .Lineweight
222.       ArcXlsheet.Cells(ii, 20).Value = .color
223.     End With
224.     ii = ii + 1
225.   Next
226. End Function

Sub ReadEntityData()   Dim Obj As AcadEntity   Dim sel As AcadSelectionSet   Dim seldata(0) As Variant, selcode(0) As Integer   Dim gpdata As Variant, gpcode As Variant   Dim pt(0 To 2) As Double, pt1(0 To 2) As Double     With ThisDrawing         ret = .Utility.GetPoint(, "指定左上角：")         SetRet ret, pt         ret = .Utility.GetCorner(pt, "指定对角点：")         SetRet ret, pt1         Set sel = .SelectionSets.Add("ss")         selcode(0) = 0: gpcode = selcode         seldata(0) = "Line": gpdata = seldata         sel.Select acSelectionSetCrossing, pt, pt1, gpcode, gpdata         Debug.Print "Line ", sel.Count         .SelectionSets.Item("ss").Clear         'Set sel = .SelectionSets.Add("ss")         selcode(0) = 0: gpcode = selcode         seldata(0) = "Dimension": gpdata = seldata         sel.Select acSelectionSetCrossing, pt, pt1, gpcode, gpdata         Debug.Print "Dimension ", sel.Count                  .SelectionSets.Item("ss").Delete     End With     End Sub Private Sub SetRet(ret As Variant, pt() As Double)     pt(0) = ret(0)     pt(1) = ret(1)     pt(2) = ret(2) End Sub Function xlApp() As Object '  Dim xlApp As Object    ' This Line ,Not set Excel , run Excel      'Dim xlsheet As Object            ' 发生错误时跳到下一个语句继续执行      On Error Resume Next      ' 连接Excel应用程序      Set xlApp = GetObject(, "Excel.Application")            If Err.Number <> 0 Then          Set xlApp = CreateObject("Excel.Application")          xlApp.Visible = True          xlApp.Workbooks.Add      End If      ' 返回当前活动的工作表 End Function Sub ObjectToExcel()   Set ArcXlsheet = xlApp.Sheets(1)   ArcXlsheet.Name = "Arc"   Set CircleXlSheet = xlApp.Sheets(2)   CircleXlSheet.Name = "Circle"   Set PolylineXlSheet = xlApp.Sheets(3)   PolylineXlSheet.Name = "Polyline"   Set LineXlsheet = xlApp.Sheets.Add   LineXlsheet.Name = "Line"   Set Mtextxlsheet = xlApp.Sheets.Add   Mtextxlsheet.Name = "MText"   Set TextXlSheet = xlApp.Sheets.Add   TextXlSheet.Name = "Text"   Set DimensionXlSheet = xlApp.Sheets.Add   DimensionXlSheet.Name = "Dimension" End Sub Sub ls()   Dim Obj As AcadEntity   Dim sel As AcadSelectionSet, kk As AcadSelectionSet   Dim seldata(0) As Variant, selcode(0) As Integer   Dim gpdata As Variant, gpcode As Variant   Dim pt(0 To 2) As Double, pt1(0 To 2) As Double        With ThisDrawing       'If Not IsNull(ThisDrawing.SelectionSets.Item("sss")) Then         'ThisDrawing.SelectionSets.Item("sss").Delete         Set sel = .SelectionSets.Add("sss")       'End If         '' Line         selcode(0) = 0: gpcode = selcode         seldata(0) = "Line": gpdata = seldata         sel.Select acSelectionSetAll, , , gpcode, gpdata         Set kk = ReadLineAttribute(sel)         Debug.Print "Line ", sel.Count         '''         sel.Clear         seldata(0) = "Dimension": gpdata = seldata         sel.Select acSelectionSetAll, , , gpcode, gpdata         Debug.Print "Dimension ", sel.Count         ''         sel.Clear         seldata(0) = "LWPOLYLINE": gpdata = seldata         sel.Select acSelectionSetAll, , , gpcode, gpdata         Debug.Print "LWPOLYLINE ", sel.Count         ''         sel.Clear         seldata(0) = "POLYLINE": gpdata = seldata         sel.Select acSelectionSetAll, , , gpcode, gpdata         Debug.Print "POLYLINE ", sel.Count         '''         sel.Clear         seldata(0) = "Text": gpdata = seldata         sel.Select acSelectionSetAll, , , gpcode, gpdata         Debug.Print "Text ", sel.Count         ''         sel.Clear         seldata(0) = "MText": gpdata = seldata         sel.Select acSelectionSetAll, , , gpcode, gpdata         Debug.Print "MText ", sel.Count         '' Arc Data         sel.Clear         seldata(0) = "Arc": gpdata = seldata         sel.Select acSelectionSetAll, , , gpcode, gpdata         Set kk = ReadArcAttribute(sel)         ''         sel.Clear         seldata(0) = "Circle": gpdata = seldata         sel.Select acSelectionSetAll, , , gpcode, gpdata         Debug.Print "Circle ", sel.Count         ''         sel.Clear         seldata(0) = "Ellipse": gpdata = seldata         sel.Select acSelectionSetAll, , , gpcode, gpdata         Debug.Print "Ellipse ", sel.Count         ''         sel.Clear         seldata(0) = "HATCH": gpdata = seldata         sel.Select acSelectionSetAll, , , gpcode, gpdata         Debug.Print "Hatch ", sel.Count                  .SelectionSets.Item("sss").Delete     End With End Sub ' Function Line Function ReadLineAttribute(InputSel As AcadSelectionSet) As AcadSelectionSet   Dim ll As AcadLine   Set LineXlsheet = xlApp.Sheets("Line")      ii = 1     With ll       For jj = 0 To 2         LineXlsheet.Cells(ii, jj + 1).Value = "StartPoint(" & jj & ")"         LineXlsheet.Cells(ii, jj + 4).Value = "EndPoint(" & jj & ")"         LineXlsheet.Cells(ii, jj + 7).Value = "Delta(" & jj & ")"       Next jj       LineXlsheet.Cells(ii, 10).Value = "Length"       LineXlsheet.Cells(ii, 11).Value = "Layer"       LineXlsheet.Cells(ii, 12).Value = "Linetype"       LineXlsheet.Cells(ii, 13).Value = "LinetypeScale"       LineXlsheet.Cells(ii, 14).Value = "Lineweight"       LineXlsheet.Cells(ii, 15).Value = "Color"     End With         ii = 2   For Each ll In InputSel     With ll       For jj = 0 To 2         LineXlsheet.Cells(ii, jj + 1).Value = Round(.StartPoint(jj), 2)         LineXlsheet.Cells(ii, jj + 4).Value = Round(.EndPoint(jj), 2)         LineXlsheet.Cells(ii, jj + 7).Value = Round(.Delta(jj), 2)       Next jj       LineXlsheet.Cells(ii, 10).Value = .Length       LineXlsheet.Cells(ii, 11).Value = .Layer       LineXlsheet.Cells(ii, 12).Value = .Linetype       LineXlsheet.Cells(ii, 13).Value = .LinetypeScale       LineXlsheet.Cells(ii, 14).Value = .Lineweight       LineXlsheet.Cells(ii, 15).Value = .color     End With     ii = ii + 1   Next ll End Function '''Function Arc Function ReadArcAttribute(InputSel As AcadSelectionSet) As AcadSelectionSet   Dim Aa As AcadArc   Set ArcXlsheet = xlApp.Sheets("Arc")      ii = 1     With Aa       For jj = 0 To 2         ArcXlsheet.Cells(ii, jj + 1).Value = "Center(" & jj & ")"         ArcXlsheet.Cells(ii, jj + 4).Value = "StartPoint(" & jj & ")"         ArcXlsheet.Cells(ii, jj + 7).Value = "EndPoint(" & jj & ")"                Next jj       ArcXlsheet.Cells(ii, 10).Value = "StartAngle"       ArcXlsheet.Cells(ii, 11).Value = "EndAngle"       ArcXlsheet.Cells(ii, 12).Value = "TotalAngle"       ArcXlsheet.Cells(ii, 13).Value = "Radius"       ArcXlsheet.Cells(ii, 14).Value = "ArcLength"       ArcXlsheet.Cells(ii, 15).Value = "Area"       ArcXlsheet.Cells(ii, 16).Value = "Layer"       ArcXlsheet.Cells(ii, 17).Value = "Linetype"       ArcXlsheet.Cells(ii, 18).Value = "LinetypeScale"       ArcXlsheet.Cells(ii, 19).Value = "Lineweight"       ArcXlsheet.Cells(ii, 20).Value = "color"     End With         ii = 2   For Each Aa In InputSel     With Aa       For jj = 0 To 2         ArcXlsheet.Cells(ii, jj + 7).Value = Round(.Center(jj), 2)         ArcXlsheet.Cells(ii, jj + 1).Value = Round(.StartPoint(jj), 2)         ArcXlsheet.Cells(ii, jj + 4).Value = Round(.EndPoint(jj), 2)                Next jj              ArcXlsheet.Cells(ii, 10).Value = .StartAngle       ArcXlsheet.Cells(ii, 11).Value = .EndAngle       ArcXlsheet.Cells(ii, 12).Value = .TotalAngle       ArcXlsheet.Cells(ii, 13).Value = .Radius       ArcXlsheet.Cells(ii, 14).Value = .ArcLength       ArcXlsheet.Cells(ii, 15).Value = .Area       ArcXlsheet.Cells(ii, 16).Value = .Layer       ArcXlsheet.Cells(ii, 17).Value = .Linetype       ArcXlsheet.Cells(ii, 18).Value = .LinetypeScale       ArcXlsheet.Cells(ii, 19).Value = .Lineweight       ArcXlsheet.Cells(ii, 20).Value = .color     End With     ii = ii + 1   Next End Function

guanguanone

顶，再加点注释就更好了

guanguanone

为什么只写了，ReadArcAttribute和ReadLineAttribute

其它得呢，我想要个ReadTextAttribute,不知楼主可否提供，多谢

phoenixdjq

我没有用过vb程序

请问这个程序怎么用，能不能提供一个具体的加载方法

谢谢！