Excel VBA以选择多段线并将区域带回Excel

Sub PickLwPolyAndGetData()
    
    Dim MyCell As Range
    Dim ACAD As AcadApplication
    Dim LWPoly As AcadLWPolyline
    Dim ThisDrawing As AcadDocument
    Dim Pt1 As Variant
    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
          
    
    ' select LwPolyline
    On Error Resume Next
    Do
        Err.Clear
        ThisDrawing.Utility.GetEntity LWPoly, Pt1, "Select a Polyline:"
    Loop While Err
    On Error GoTo 0
    
    
    'get LWPoly data
    With LWPoly
        LWArea = .Area
        LWZ = .Elevation
    End With
    
    ' write LWPoly data on worksheet
    Set MyCell = ActiveCell
    With MyCell
        .Offset(0, 0).Value = "Area:"
        .Offset(0, 1).Value = LWArea
        .Offset(1, 0) = "Z:"
        .Offset(1, 0) = LWZ
    End With
    
    Set ThisDrawing = Nothing
    Set ACAD = Nothing
   
 End Sub

Sub PickLwPolysAndGetData()
    
'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
' 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(1, 1)
        With MyCell
            .Offset(0, 0).Value = "LWPoly nr"
            .Offset(0, 1).Value = "Area"
            .Offset(0, 2) = "Z"
        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, 3).Clear
        
        'retrieving LWPolys data and writing them on worksheet
        iRow = 1
        For Each LWPoly In ssetObj
            '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, 2) = LWZ
            End With
            iRow = iRow + 1
        Next LWPoly
        
    End If
' cleaning up before ending
    ssetObj.Delete
    Set ssetObj = Nothing
    Set ThisDrawing = Nothing
    Set ACAD = Nothing
End Sub

For Each LWPoly In ssetObj

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
' 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 LWPoly In ssetObj
       
            '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
       Next LWPoly
        
   End If
' cleaning up before ending
    ssetObj.Delete
    Set ssetObj = Nothing
    Set ThisDrawing = Nothing
    Set ACAD = Nothing
End Sub

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