[Wadim_P]

Помогите. Имеется множество слоев (от .. до 90). Необходимо подсчитать сколько в каждом слое имеется элементов. В основном элемент - 3Д-тело., и , желательно передать в Эксел, в виде
название_слоя - кол-во_эл-в (в этом слое).
Можно конечно и на Лиспе, но хотелось бы на VBA (там я немного код понимаю, разберусь...)

[Олег (jr.)]

Типа

Код:

[Выделить все]

Option Explicit
' request reference to Microsoft Excel XX.0 Object Library
' and also in the main VBAIDE menu go to:
' Tools->Options->General Tab and check 'Break on Unhandled Errors'

Sub CountSolids()
    Dim oSset As AcadSelectionSet
    Dim oEnt As AcadEntity
     Dim xlName As String
    Dim tmpStr As String
    Dim i As Long, j As Long
    Dim counter As Integer, m As Integer
    Dim ftype(0) As Integer
    Dim fdata(0) As Variant
    Dim dxfCode, dxfValue
    Dim total As Long
    On Error GoTo Err_Control

    ftype(0) = 0
    fdata(0) = "3DSOLID"
    dxfCode = ftype: dxfValue = fdata

    With ThisDrawing.SelectionSets
        While .Count > 0
            .Item(0).Delete
        Wend
        Set oSset = .Add("$3dSolids$")
    End With
    oSset.Select acSelectionSetAll, , , dxfCode, dxfValue
MsgBox oSset.Count

    Dim uniqColl As New Collection
    Dim countColl As New Collection
'
    For Each oEnt In oSset
        On Error Resume Next
    uniqColl.Add oEnt.Layer, oEnt.Layer
    Next oEnt
'
    If Err Then
        Err.Clear
    End If
'
    For i = 1 To uniqColl.Count

        tmpStr = uniqColl.Item(i)
        counter = 0
        For Each oEnt In oSset

                If StrComp(tmpStr, oEnt.Layer, 1) = 0 Then
                    counter = counter + 1
                End If

        Next oEnt

        ReDim tmp(1) As String
        tmp(0) = tmpStr: tmp(1) = CStr(counter)
        countColl.Add tmp, tmpStr
        total = total + counter
    Next i
'
    DoEvents
    
    ''~~~~~~~~~ Excel part ~~~~~~~~~''
    
    xlName = "SolidsCount"
    Dim xlApp As Excel.Application
    Dim xlBooks As Excel.Workbooks
    Dim xlBook As Excel.Workbook
    Dim xlSheet As Excel.Worksheet

    Set xlApp = GetExcelOpen

    If Not xlApp Is Nothing Then
        xlApp.Visible = True
        Debug.Print "Success"

    Else
        Debug.Print "Failed"
        Exit Sub
    End If

    Set xlBooks = xlApp.Workbooks

    xlBooks.Add
    Set xlBook = xlApp.ActiveWorkbook

    Set xlSheet = xlBook.Sheets(1)

    xlSheet.Name = "Solids Count"
    xlSheet.Activate

    With xlSheet
    .Cells(1, 1) = "Layer": .Cells(1, 2) = "Quantity"
        Dim itm As Variant
        For i = 1 To countColl.Count
            itm = countColl.Item(i)
            For j = 0 To UBound(itm)
                .Cells(i + 1, j + 1) = itm(j)
            Next
        Next
        .Cells(i + 1, 1) = "Total:": .Cells(i + 1, 2) = CStr(total)
        .Columns.HorizontalAlignment = xlHAlignLeft
        .Columns.AutoFit
    End With

    xlBook.SaveAs ThisDrawing.Path & "\" & xlName & ".xls"
    xlBook.Close

    xlApp.Application.Quit

    Set xlSheet = Nothing
    Set xlBook = Nothing
    Set xlBooks = Nothing
    Set xlApp = Nothing

    DoEvents

    MsgBox "Done"

Err_Control:
If Err.Number <> 0 Then
    MsgBox Err.Description
    End If

End Sub

'' written by Joe Sutphin
Public Function GetExcelOpen() As Excel.Application

    On Error Resume Next

    Set GetExcelOpen = GetObject(, "Excel.Application")

    If Err Then
        Err.Clear

        Set GetExcelOpen = CreateObject("Excel.Application")

        If Err Then
            MsgBox "Could not start Excel Application", vbExclamation
            Exit Function
        End If
    End If

End Function

~'J'~

[Wadim_P]

Огромное спасибо !!!

[Олег (jr.)]

Успехов

~'J'~