---

Private Sub ДиагностикаТел()

    Dim App5 As Object
    Dim Doc3D As Object
    Dim TopPart As Object
    Dim Bodies As Object
    Dim Body As Object
    Dim Body7 As Object

    Dim i As Long
    Dim CountBodies As Long

    Dim Msg As String
    Dim Marking As String
    Dim BodyName As String

    On Error GoTo FatalError

    Msg = "ДИАГНОСТИКА ТЕЛ" & vbCrLf
    Msg = Msg & String(60, "-") & vbCrLf

    ' =========================================================
    ' API 5
    ' =========================================================

    On Error Resume Next
    Set App5 = CreateObject("Kompas.Application.5")

    If App5 Is Nothing Then
        Set App5 = GetObject(, "Kompas.Application.5")
    End If

    On Error GoTo FatalError

    If App5 Is Nothing Then

        Msg = Msg & "API5: НЕ ПОЛУЧЕН" & vbCrLf

        MsgBox Msg, vbCritical, "Диагностика"

        Exit Sub

    End If

    Msg = Msg & "API5: OK" & vbCrLf


    ' =========================================================
    ' ACTIVE DOCUMENT 3D
    ' =========================================================

    Set Doc3D = Nothing

    On Error Resume Next

    Set Doc3D = App5.ActiveDocument3D

    On Error GoTo FatalError

    If Doc3D Is Nothing Then

        Msg = Msg & "ActiveDocument3D: НЕ ПОЛУЧЕН" & vbCrLf

        MsgBox Msg, vbCritical, "Диагностика"

        Exit Sub

    End If

    Msg = Msg & "ActiveDocument3D: OK" & vbCrLf


    ' =========================================================
    ' TOP PART
    ' =========================================================

    Set TopPart = Nothing

    On Error Resume Next

    Set TopPart = Doc3D.TopPart

    On Error GoTo FatalError

    If TopPart Is Nothing Then

        Msg = Msg & "TopPart: НЕ ПОЛУЧЕН" & vbCrLf

        MsgBox Msg, vbCritical, "Диагностика"

        Exit Sub

    End If

    Msg = Msg & "TopPart: OK" & vbCrLf


    ' =========================================================
    ' BODY COLLECTION
    ' =========================================================

    Set Bodies = Nothing

    On Error Resume Next

    Set Bodies = TopPart.BodyCollection

    On Error GoTo FatalError

    If Bodies Is Nothing Then

        Msg = Msg & "BodyCollection: НЕ ПОЛУЧЕН" & vbCrLf

        MsgBox Msg, vbCritical, "Диагностика"

        Exit Sub

    End If

    Msg = Msg & "BodyCollection: OK" & vbCrLf


    ' =========================================================
    ' КОЛИЧЕСТВО
    ' =========================================================

    CountBodies = 0

    On Error Resume Next

    CountBodies = Bodies.GetCount

    If Err.Number <> 0 Then

        Err.Clear

        CountBodies = Bodies.Count

    End If

    On Error GoTo FatalError

    Msg = Msg & "Количество тел: " & CountBodies & vbCrLf
    Msg = Msg & String(60, "-") & vbCrLf


    ' =========================================================
    ' ОБХОД ТЕЛ
    ' =========================================================

    For i = 0 To CountBodies - 1

        Set Body = Nothing
        Set Body7 = Nothing

        Marking = ""
        BodyName = ""

        ' -----------------------------------------------------
        ' ksBody
        ' -----------------------------------------------------

        On Error Resume Next

        Set Body = Bodies.GetByIndex(i)

        On Error GoTo FatalError


        Msg = Msg & vbCrLf
        Msg = Msg & "ТЕЛО №" & (i + 1) & vbCrLf


        If Body Is Nothing Then

            Msg = Msg & "  ksBody: НЕ ПОЛУЧЕН" & vbCrLf

            GoTo NextBody

        Else

            Msg = Msg & "  ksBody: OK" & vbCrLf

        End If


        ' =====================================================
        ' ПОЛУЧЕНИЕ IBody7 ЧЕРЕЗ TransferInterface
        ' =====================================================

        On Error Resume Next

        Set Body7 = App5.TransferInterface( _
                        Body, _
                        7, _
                        0)

        On Error GoTo FatalError


        If Body7 Is Nothing Then

            Msg = Msg & "  IBody7: НЕ ПОЛУЧЕН" & vbCrLf

            ' Попробуем получить через IUnknown/COM
            On Error Resume Next

            Set Body7 = Body

            On Error GoTo FatalError

        End If


        If Body7 Is Nothing Then

            Msg = Msg & "  IBody7 через Body: НЕ ПОЛУЧЕН" & vbCrLf

            GoTo NextBody

        Else

            Msg = Msg & "  IBody7: OK" & vbCrLf

        End If


        ' =====================================================
        ' NAME
        ' =====================================================

        On Error Resume Next

        Err.Clear

        BodyName = CStr(Body7.Name)

        If Err.Number <> 0 Then

            Err.Clear
            BodyName = ""

        End If

        On Error GoTo FatalError


        If Len(BodyName) > 0 Then

            Msg = Msg & _
                "  Name: " & BodyName & vbCrLf

        Else

            Msg = Msg & _
                "  Name: НЕ ПОЛУЧЕН" & vbCrLf

        End If


        ' =====================================================
        ' MARKING
        ' =====================================================

        On Error Resume Next

        Err.Clear

        Marking = CStr(Body7.Marking)

        If Err.Number <> 0 Then

            Err.Clear
            Marking = ""

        End If

        On Error GoTo FatalError


        If Len(Marking) > 0 Then

            Msg = Msg & _
                "  Marking: " & Marking & vbCrLf

        Else

            Msg = Msg & _
                "  Marking: ПУСТО" & vbCrLf

        End If


NextBody:

        ' -----------------------------------------------------
        ' Ограничение окна
        ' -----------------------------------------------------

        If Len(Msg) > 12000 Then

            Msg = Msg & vbCrLf
            Msg = Msg & _
                "Показаны первые тела. " & _
                "Всего найдено: " & CountBodies

            Exit For

        End If

    Next i


    ' =========================================================
    ' РЕЗУЛЬТАТ
    ' =========================================================

    MsgBox _
        Msg, _
        vbInformation, _
        "Диагностика тел КОМПАС-3D"

    Exit Sub


FatalError:

    Msg = Msg & vbCrLf & _
          "КРИТИЧЕСКАЯ ОШИБКА" & vbCrLf & _
          "№ " & Err.Number & vbCrLf & _
          Err.Description

    MsgBox _
        Msg, _
        vbCritical, _
        "Диагностика"

End Sub