按实体对象提取数据到Excel
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
顶，再加点注释就更好了 <p>为什么只写了，ReadArcAttribute和ReadLineAttribute</p><p>其它得呢，我想要个ReadTextAttribute,不知楼主可否提供，多谢</p> <p>我没有用过vb程序</p><p>请问这个程序怎么用，能不能提供一个具体的加载方法</p><p>谢谢！</p>
页:
[1]