---

Option Explicit

' ============================================================
' ДИАГНОСТИКА ТЕЛ / ТРУБОПРОВОДОВ КОМПАС-3D v25
'
' Ищет:
'   1. Обычные Part7
'   2. Тела IBody7
'   3. Элементарные тела
'   4. Трубчатые элементы
'
' Ничего не изменяет в КОМПАС.
' ============================================================


Public Sub ДиагностикаТелМеталлоконструкций()

    Dim App As Object
    Dim Doc As Object
    Dim Part As Object
    Dim Container As Object

    Dim ws As Worksheet
    Dim Row As Long

    On Error GoTo ErrorHandler

    ' --------------------------------------------------------
    ' СОЗДАЁМ ЛИСТ ДИАГНОСТИКИ
    ' --------------------------------------------------------

    Set ws = СоздатьЛистДиагностики()

    ws.Cells.Clear

    ws.Cells(1, 1).Value = "ДИАГНОСТИКА ОБЪЕКТОВ КОМПАС-3D v25"

    ws.Cells(1, 1).Font.Bold = True
    ws.Cells(1, 1).Font.Size = 14

    ws.Cells(3, 1).Value = "№"
    ws.Cells(3, 2).Value = "Тип"
    ws.Cells(3, 3).Value = "Имя"
    ws.Cells(3, 4).Value = "Обозначение"
    ws.Cells(3, 5).Value = "Доп. информация"

    ws.Range("A3:E3").Font.Bold = True

    Row = 4


    ' --------------------------------------------------------
    ' ПОДКЛЮЧАЕМСЯ К КОМПАС
    ' --------------------------------------------------------

    Set App = ПолучитьКомпас25()

    If App Is Nothing Then

        MsgBox _
            "Не удалось подключиться к КОМПАС-3D." & _
            vbCrLf & vbCrLf & _
            "Убедись, что КОМПАС запущен.", _
            vbCritical, _
            "Диагностика"

        Exit Sub

    End If


    ' --------------------------------------------------------
    ' АКТИВНЫЙ ДОКУМЕНТ
    ' --------------------------------------------------------

    On Error Resume Next

    Set Doc = App.ActiveDocument

    On Error GoTo ErrorHandler


    If Doc Is Nothing Then

        MsgBox _
            "Активный документ КОМПАС не получен.", _
            vbExclamation, _
            "Диагностика"

        Exit Sub

    End If


    ' --------------------------------------------------------
    ' ПРОБУЕМ ПОЛУЧИТЬ TOP PART
    '
    ' Здесь мы НЕ прекращаем работу при ошибке.
    ' Наша задача — выяснить, какие объекты реально
    ' доступны через API.
    ' --------------------------------------------------------

    On Error Resume Next

    Set Part = Nothing

    Set Part = Doc.TopPart

    On Error GoTo ErrorHandler


    If Part Is Nothing Then

        ' Пробуем получить TopPart через свойство
        ' активного документа другим способом.

        On Error Resume Next

        Set Part = Doc.Document3D.TopPart

        On Error GoTo ErrorHandler

    End If


    If Part Is Nothing Then

        ДобавитьДиагностику _
            ws, _
            Row, _
            "Документ", _
            "TopPart не получен", _
            "", _
            "Невозможно получить корневой Part"

        GoTo Завершение

    End If


    ' --------------------------------------------------------
    ' TOP PART ПОЛУЧЕН
    ' --------------------------------------------------------

    ДобавитьДиагностику _
        ws, _
        Row, _
        "Part", _
        ПолучитьСтроковоеСвойство(Part, "Name"), _
        ПолучитьСтроковоеСвойство(Part, "Marking"), _
        "Корневой компонент"


    ' --------------------------------------------------------
    ' MODEL CONTAINER
    ' --------------------------------------------------------

    Set Container = Nothing

    On Error Resume Next

    Set Container = Part.ModelContainer

    If Container Is Nothing Then

        Set Container = Part.GetModelContainer

    End If

    On Error GoTo ErrorHandler


    If Container Is Nothing Then

        ДобавитьДиагностику _
            ws, _
            Row, _
            "ModelContainer", _
            "НЕ ПОЛУЧЕН", _
            "", _
            "IModelContainer недоступен"

        GoTo Завершение

    End If


    ДобавитьДиагностику _
        ws, _
        Row, _
        "ModelContainer", _
        "ПОЛУЧЕН", _
        "", _
        "Контейнер объектов модели"


    ' ========================================================
    ' 1. ОБЫЧНЫЕ ОБЪЕКТЫ МОДЕЛИ
    ' ========================================================

    ДиагностироватьObjects _
        Container, _
        ws, _
        Row


    ' ========================================================
    ' 2. ELEMENTARY BODIES
    ' ========================================================

    ДиагностироватьElementaryBodies _
        Container, _
        ws, _
        Row


    ' ========================================================
    ' 3. PIPE ELEMENTS
    ' ========================================================

    ДиагностироватьPipeElements _
        Container, _
        ws, _
        Row


    ' ========================================================
    ' 4. РЕЗУЛЬТАТЫ
    ' ========================================================

Завершение:

    ws.Columns("A:E").AutoFit

    ws.Columns("E:E").ColumnWidth = 45

    ws.Rows(1).Font.Bold = True

    MsgBox _
        "Диагностика завершена." & _
        vbCrLf & vbCrLf & _
        "Результат находится на листе:" & _
        vbCrLf & _
        ws.Name, _
        vbInformation, _
        "Диагностика"

    Exit Sub


ErrorHandler:

    MsgBox _
        "Ошибка диагностики:" & _
        vbCrLf & vbCrLf & _
        "Номер: " & Err.Number & _
        vbCrLf & _
        "Описание: " & Err.Description, _
        vbCritical, _
        "Диагностика"

End Sub



' ============================================================
' ПОЛУЧЕНИЕ КОМПАС
' ============================================================

Private Function ПолучитьКомпас25() As Object

    Dim App As Object

    On Error Resume Next

    Set App = GetObject(, "KOMPAS.Application.7")

    On Error GoTo 0

    If Not App Is Nothing Then

        Set ПолучитьКомпас25 = App

        Exit Function

    End If


    ' --------------------------------------------------------
    ' Второй вариант
    ' --------------------------------------------------------

    On Error Resume Next

    Set App = GetObject(, "Kompas.Application.7")

    On Error GoTo 0

    If Not App Is Nothing Then

        Set ПолучитьКомпас25 = App

        Exit Function

    End If


    Set ПолучитьКомпас25 = Nothing

End Function



' ============================================================
' ОБЫЧНЫЕ OBJECTS
' ============================================================

Private Sub ДиагностироватьObjects( _
    ByVal Container As Object, _
    ByVal ws As Worksheet, _
    ByRef Row As Long)

    Dim Objects As Object
    Dim Obj As Object

    Dim i As Long
    Dim Count As Long

    On Error Resume Next

    Set Objects = Container.Objects

    If Objects Is Nothing Then

        Set Objects = Container.GetObjects

    End If

    If Err.Number <> 0 Then

        Err.Clear

        On Error GoTo 0

        ДобавитьДиагностику _
            ws, _
            Row, _
            "Objects", _
            "ОШИБКА", _
            "", _
            "Не удалось получить коллекцию Objects"

        Exit Sub

    End If

    On Error GoTo 0


    If Objects Is Nothing Then

        ДобавитьДиагностику _
            ws, _
            Row, _
            "Objects", _
            "НЕ ПОЛУЧЕН", _
            "", _
            "Коллекция отсутствует"

        Exit Sub

    End If


    Count = БезопасныйCount(Objects)


    ДобавитьДиагностику _
        ws, _
        Row, _
        "Objects", _
        "Количество: " & Count, _
        "", _
        "Обычные объекты модели"


    For i = 0 To Count - 1

        Set Obj = Nothing

        On Error Resume Next

        Set Obj = Objects.Item(i)

        If Obj Is Nothing Then

            Set Obj = Objects.Item(i + 1)

        End If

        On Error GoTo 0


        If Not Obj Is Nothing Then

            ДиагностироватьОдинОбъект _
                Obj, _
                ws, _
                Row, _
                "ModelObject"

        End If

    Next i

End Sub



' ============================================================
' ELEMENTARY BODIES
' ============================================================

Private Sub ДиагностироватьElementaryBodies( _
    ByVal Container As Object, _
    ByVal ws As Worksheet, _
    ByRef Row As Long)

    Dim Bodies As Object
    Dim Body As Object

    Dim i As Long
    Dim Count As Long

    On Error Resume Next

    Set Bodies = Container.ElementaryBodies

    If Bodies Is Nothing Then

        Set Bodies = Container.GetElementaryBodies

    End If

    If Err.Number <> 0 Then

        Err.Clear

        On Error GoTo 0

        ДобавитьДиагностику _
            ws, _
            Row, _
            "ElementaryBodies", _
            "ОШИБКА", _
            "", _
            "Свойство недоступно"

        Exit Sub

    End If

    On Error GoTo 0


    If Bodies Is Nothing Then

        ДобавитьДиагностику _
            ws, _
            Row, _
            "ElementaryBodies", _
            "НЕ ПОЛУЧЕН", _
            "", _
            "Коллекция элементарных тел отсутствует"

        Exit Sub

    End If


    Count = БезопасныйCount(Bodies)


    ДобавитьДиагностику _
        ws, _
        Row, _
        "ElementaryBodies", _
        "Количество: " & Count, _
        "", _
        "Элементарные тела"


    For i = 0 To Count - 1

        Set Body = Nothing

        On Error Resume Next

        Set Body = Bodies.Item(i)

        If Body Is Nothing Then

            Set Body = Bodies.Item(i + 1)

        End If

        On Error GoTo 0


        If Not Body Is Nothing Then

            ДиагностироватьОдинОбъект _
                Body, _
                ws, _
                Row, _
                "ElementaryBody"

        End If

    Next i

End Sub



' ============================================================
' PIPE ELEMENTS
' ============================================================

Private Sub ДиагностироватьPipeElements( _
    ByVal Container As Object, _
    ByVal ws As Worksheet, _
    ByRef Row As Long)

    Dim Pipes As Object
    Dim Pipe As Object

    Dim i As Long
    Dim Count As Long

    On Error Resume Next

    Set Pipes = Container.PipeElements

    If Pipes Is Nothing Then

        Set Pipes = Container.GetPipeElements

    End If

    If Err.Number <> 0 Then

        Err.Clear

        On Error GoTo 0

        ДобавитьДиагностику _
            ws, _
            Row, _
            "PipeElements", _
            "ОШИБКА", _
            "", _
            "Свойство недоступно"

        Exit Sub

    End If

    On Error GoTo 0


    If Pipes Is Nothing Then

        ДобавитьДиагностику _
            ws, _
            Row, _
            "PipeElements", _
            "НЕ ПОЛУЧЕН", _
            "", _
            "Коллекция трубчатых элементов отсутствует"

        Exit Sub

    End If


    Count = БезопасныйCount(Pipes)


    ДобавитьДиагностику _
        ws, _
        Row, _
        "PipeElements", _
        "Количество: " & Count, _
        "", _
        "Трубчатые элементы КОМПАС"


    For i = 0 To Count - 1

        Set Pipe = Nothing

        On Error Resume Next

        Set Pipe = Pipes.Item(i)

        If Pipe Is Nothing Then

            Set Pipe = Pipes.Item(i + 1)

        End If

        On Error GoTo 0


        If Not Pipe Is Nothing Then

            ДиагностироватьОдинОбъект _
                Pipe, _
                ws, _
                Row, _
                "PipeElement"

        End If

    Next i

End Sub



' ============================================================
' ДИАГНОСТИКА ОДНОГО ОБЪЕКТА
' ============================================================

Private Sub ДиагностироватьОдинОбъект( _
    ByVal Obj As Object, _
    ByVal ws As Worksheet, _
    ByRef Row As Long, _
    ByVal ObjectType As String)

    Dim Name As String
    Dim Marking As String
    Dim FileName As String
    Dim TypeName As String
    Dim Info As String

    Name = ПолучитьСтроковоеСвойство(Obj, "Name")

    Marking = ПолучитьСтроковоеСвойство(Obj, "Marking")

    If Len(Marking) = 0 Then

        Marking = ПолучитьСтроковоеСвойство(Obj, "SourceMarking")

    End If

    FileName = ПолучитьСтроковоеСвойство(Obj, "FileName")

    TypeName = ПолучитьСтроковоеСвойство(Obj, "ObjectType")

    Info = ""

    If Len(FileName) > 0 Then

        Info = "FileName=" & FileName

    End If

    If Len(TypeName) > 0 Then

        If Len(Info) > 0 Then Info = Info & "; "

        Info = Info & "ObjectType=" & TypeName

    End If


    ДобавитьДиагностику _
        ws, _
        Row, _
        ObjectType, _
        Name, _
        Marking, _
        Info

End Sub



' ============================================================
' БЕЗОПАСНОЕ ПОЛУЧЕНИЕ СТРОКОВОГО СВОЙСТВА
' ============================================================

Private Function ПолучитьСтроковоеСвойство( _
    ByVal Obj As Object, _
    ByVal PropertyName As String) As String

    Dim Value As Variant

    On Error Resume Next

    Err.Clear

    Value = CallByName( _
        Obj, _
        PropertyName, _
        VbGet)

    If Err.Number <> 0 Then

        Err.Clear

        ПолучитьСтроковоеСвойство = ""

        Exit Function

    End If

    On Error GoTo 0


    If IsNull(Value) Then

        ПолучитьСтроковоеСвойство = ""

    Else

        ПолучитьСтроковоеСвойство = CStr(Value)

    End If

End Function



' ============================================================
' COUNT
' ============================================================

Private Function БезопасныйCount( _
    ByVal CollectionObject As Object) As Long

    On Error Resume Next

    Err.Clear

    БезопасныйCount = CLng( _
        CallByName( _
            CollectionObject, _
            "Count", _
            VbGet))

    If Err.Number <> 0 Then

        Err.Clear

        БезопасныйCount = 0

    End If

    On Error GoTo 0

End Function



' ============================================================
' ДОБАВЛЕНИЕ СТРОКИ
' ============================================================

Private Sub ДобавитьДиагностику( _
    ByVal ws As Worksheet, _
    ByRef Row As Long, _
    ByVal ObjectType As String, _
    ByVal Name As String, _
    ByVal Marking As String, _
    ByVal Info As String)

    ws.Cells(Row, 1).Value = Row - 3
    ws.Cells(Row, 2).Value = ObjectType
    ws.Cells(Row, 3).Value = Name
    ws.Cells(Row, 4).Value = Marking
    ws.Cells(Row, 5).Value = Info

    Row = Row + 1

End Sub



' ============================================================
' СОЗДАНИЕ ЛИСТА
' ============================================================

Private Function СоздатьЛистДиагностики() As Worksheet

    Dim ws As Worksheet

    On Error Resume Next

    Set ws = ThisWorkbook.Worksheets("ДиагностикаТел")

    On Error GoTo 0


    If ws Is Nothing Then

        Set ws = ThisWorkbook.Worksheets.Add

        ws.Name = "ДиагностикаТел"

    End If


    Set СоздатьЛистДиагностики = ws

End Function