[编程交流] Auto cad-->excel

   Option Explicit
Sub PutPLProps2XL()
Dim strLayName As String
  strLayName = GetObjectLayer()
  If strLayName <> "" Then
     If ClosedPLSS(strLayName) Then
        Dim objSS As AcadSelectionSet
        Dim entEntity As AcadEntity
        Dim objExcel As Excel.Application
        Dim objRange As Excel.Range
        Dim entLWPoly As AcadLWPolyline
        Dim ent2DPoly As AcadPolyline
        Dim intCount As Integer
           On Error GoTo errHandler
           Set objExcel = GetObject(, "Excel.Application")
           On Error GoTo 0
           Set objRange = objExcel.ActiveWorkbook.ActiveSheet.Range("A1")
           objRange.value = "Layer"
           objRange.Offset(0, 1).value = "Pline Type"
           objRange.Offset(0, 2).value = "Length"
           objRange.Offset(0, 3).value = "Area"
              Set objSS = ThisDrawing.SelectionSets.Item("TempSSet")
              For intCount = 0 To objSS.count - 1
                 Set entEntity = objSS.Item(intCount)
                 If entEntity.ObjectName = "AcDbPolyline" Then
                    Set entLWPoly = entEntity
                    objRange.Offset(intCount + 1, 0).value = entLWPoly.Layer
                    objRange.Offset(intCount + 1, 1).value = "LWPolyline"
                    objRange.Offset(intCount + 1, 2).value = entLWPoly.Length
                    objRange.Offset(intCount + 1, 3).value = entLWPoly.Area
                 Else
                    Set ent2DPoly = entEntity
                    objRange.Offset(intCount + 1, 0).value = ent2DPoly.Layer
                    objRange.Offset(intCount + 1, 1).value = "2DPolyline"
                    objRange.Offset(intCount + 1, 2).value = ent2DPoly.Length
                    objRange.Offset(intCount + 1, 3).value = ent2DPoly.Area
                 End If
              Next
     Set objExcel = Nothing
     End If
  End If
  Exit Sub
errHandler:
  Err.Clear
  Set objExcel = CreateObject("Excel.Application")
  With objExcel
     .Workbooks.Add
     .Visible = True
     .WindowState = xlMinimized
  End With
  Resume Next
End Sub
Function ClosedPLSS(strLayName As String) As Boolean
  Dim intCode(21) As Integer
  Dim varData(21) As Variant
  ClosedPLSS = False
  intCode(0) = -4: varData(0) = "<Or"
     intCode(1) = -4: varData(1) = "<And"
        intCode(2) = 0: varData(2) = "POLYLINE" 'or closed PLINES's
        intCode(3) = -4: varData(3) = "&="
        intCode(4) = 70: varData(4) = 1
        intCode(5) = -4: varData(5) = "&"
        intCode(6) = 70: varData(6) = 135
        intCode(7) = -4: varData(7) = "<Not"
           intCode( = -4: varData( = "&="
           intCode(9) = 70: varData(9) = 8
        intCode(10) = -4: varData(10) = "Not>"
        intCode(11) = 8: varData(11) = strLayName
     intCode(12) = -4: varData(12) = "And>"
     
     intCode(13) = -4: varData(13) = "<And"
        intCode(14) = 0: varData(14) = "LWPOLYLINE" 'or closed LWP's
        intCode(15) = -4: varData(15) = "&="
        intCode(16) = 70: varData(16) = 1
        intCode(17) = -4: varData(17) = "&"
        intCode(18) = 70: varData(18) = 129
        intCode(19) = 8: varData(19) = strLayName
     intCode(20) = -4: varData(20) = "And>"
  intCode(21) = -4: varData(21) = "Or>"
  
  If FilteredSS(intCode, varData) > 0 Then ClosedPLSS = True
End Function
Private Sub SSPrep()
Dim SSS As AcadSelectionSets
  'choose a selection set name for temporary storage and
  'ensure that it does not currently exist
  On Error Resume Next
  Set SSS = ThisDrawing.SelectionSets
     If SSS.count > 0 Then
        SSS.Item("TempSSet").Delete
     End If
End Sub
Function FilteredSS(Optional grpCode As Variant, Optional dataVal As Variant) As Integer
  Dim TempObjSS As AcadSelectionSet
  SSPrep
  Set TempObjSS = ThisDrawing.SelectionSets.Add("TempSSet")
        'generate selection set
     TempObjSS.Select acSelectionSetAll, , , grpCode, dataVal
  FilteredSS = TempObjSS.count
End Function
Function GetObjectLayer() As String
Dim ent As AcadEntity
Dim varPickPT As Variant
  On Error GoTo errHandler
  ThisDrawing.Utility.GetEntity ent, varPickPT, "Select an entity on a layer with which to focus: "
  GetObjectLayer = ent.Layer
  Exit Function
errHandler:
  GetObjectLayer = ""
End Function