Sub Import_POLYLINES()
'for Excel sheet managing purposes
Dim MySht As Worksheet
Dim MyCell As range
'for Autocad application managing purposes
Dim ACAD As AcadApplication
Dim ThisDrawing As AcadDocument
Dim LWPoly As AcadLWPolyline
Dim oEnt As AcadEntity
' for selection set purposes
Dim ssetObj As AcadSelectionSet
Dim gpCode(0) As Integer
Dim dataValue(0) As Variant
'for general variables managing purposes
Dim iRow As Long
Dim LWArea As Double, LWZ As Double
' Autocad Session handling
On Error Resume Next
Set ACAD = GetObject(, "AutoCAD.Application")
On Error GoTo 0
If ACAD Is Nothing Then
Set ACAD = New AcadApplication
ACAD.Visible = True
End If
Set ThisDrawing = ACAD.ActiveDocument
' selecting LwPolylines on screen by selelection set filtering method
' managing potential selection set exsistence
On Error Resume Next
Set ssetObj = ThisDrawing.SelectionSets.Item("LWPolySSET")
If Err Then Set ssetObj = ThisDrawing.SelectionSets.Add("LWPolySSET")
On Error GoTo 0
ssetObj.Clear
'setting filtering critera
gpCode(0) = 0
dataValue(0) = "LWPOLYLINE"
'selecting LWPolylines
ssetObj.SelectOnScreen gpCode, dataValue
' processing LWPolylines
If ssetObj.Count > 0 Then
' writing sheet headings
Set MySht = ActiveSheet
Set MyCell = MySht.Cells(11, 1) 'Where to Start the Excel Cell Input X, Y
With MyCell
'.Offset(0, 0).Value = "LWPoly nr"
'.Offset(0, 1).Value = "Area S.F."
'.Offset(0, 0) = "Elevation"
End With
'clearing previous written data
iRow = MySht.Cells(MySht.Rows.Count, 1).End(xlUp).Row
If iRow > 1 Then MyCell.Offset(1, 0).Resize(iRow - 1, 2).Clear
'retrieving LWPolys data and writing them on worksheet
iRow = 1
For Each oEnt In ssetObj
If TypeOf oEnt Is AcadLWPolyline Then
Set LWPoly = oEnt
'retrieving LWPoly data
With LWPoly
LWArea = .area
LWZ = .Elevation
End With
' writing LWPoly data
With MyCell
'.Offset(iRow, 0).Value = "LWPoly nr." & iRow
.Offset(iRow, 1).Value = LWArea
.Offset(iRow, 0) = LWZ
End With
iRow = iRow + 1
End If
Next oEnt
End If
' cleaning up before ending
ssetObj.Delete
Set ssetObj = Nothing
Set ThisDrawing = Nothing
Set ACAD = Nothing
End Sub 它可以编译吗？ 是的，它确实可以编译。如果调试器出现，我可以完成宏。据我所知，它在2013年没有出现任何问题。但自从我们升级到2014年，它就出现了。我所有的参考资料也都更新了。我有一个包裹宏，我做了更新，并与2014年的工作（缓慢）。我只是不能得到这个多段线了。 如果你把图纸发给我，我可以看一看。但在Acad2010中，无论如何，它可能会对你有用。
页:
1
[2]