---

Option Explicit

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

    Dim App5 As Object
    Dim Doc3D As Object
    Dim Part5 As Object
    Dim Part7 As Object

    Dim Bodies As Object
    Dim Body As Object
    Dim Body7 As Object

    Dim CountBodies As Long
    Dim i As Long

    Dim Report As String

    Dim NameText As String
    Dim MarkingText As String
    Dim IdText As String

    On Error GoTo FatalError

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

    Set App5 = Nothing

    On Error Resume Next
    Set App5 = GetObject(, "Kompas.Application.5")
    On Error GoTo FatalError

    If App5 Is Nothing Then

        MsgBox _
            "API 5 НЕ ПОЛУЧЕН.", _
            vbCritical, _
            "Диагностика тел"

        Exit Sub

    End If

    Report = "API 5: ОК" & vbCrLf


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

    Set Doc3D = Nothing

    On Error Resume Next
    Set Doc3D = App5.ActiveDocument3D
    On Error GoTo FatalError

    If Doc3D Is Nothing Then

        MsgBox _
            Report & vbCrLf & _
            "ActiveDocument3D: НЕ ПОЛУЧЕН", _
            vbCritical, _
            "Диагностика тел"

        Exit Sub

    End If

    Report = Report & _
             "ActiveDocument3D: ОК" & vbCrLf


    ' ========================================================
    ' GETPART(-1)
    ' ========================================================

    Set Part5 = Nothing

    On Error Resume Next
    Set Part5 = Doc3D.GetPart(-1)
    On Error GoTo FatalError

    If Part5 Is Nothing Then

        MsgBox _
            Report & vbCrLf & _
            "GetPart(-1): НЕ ПОЛУЧЕН", _
            vbCritical, _
            "Диагностика тел"

        Exit Sub

    End If

    Report = Report & _
             "GetPart(-1): ОК" & vbCrLf


    ' ========================================================
    ' API 7 PART
    ' ========================================================

    Set Part7 = Nothing

    On Error Resume Next
    Set Part7 = Part5
    On Error GoTo FatalError

    If Part7 Is Nothing Then

        MsgBox _
            Report & vbCrLf & _
            "IPart7: НЕ ПОЛУЧЕН", _
            vbCritical, _
            "Диагностика тел"

        Exit Sub

    End If

    Report = Report & _
             "IPart7: ОК" & vbCrLf


    ' ========================================================
    ' KS BODY COLLECTION
    '
    ' ВАЖНО:
    ' здесь получаем именно API5 ksBodyCollection
    ' через BodyCollection()
    ' ========================================================

    Set Bodies = Nothing

    On Error Resume Next

    Set Bodies = Part5.BodyCollection

    On Error GoTo FatalError

    If Bodies Is Nothing Then

        MsgBox _
            Report & vbCrLf & _
            "ksBodyCollection: НЕ ПОЛУЧЕН", _
            vbCritical, _
            "Диагностика тел"

        Exit Sub

    End If

    Report = Report & _
             "ksBodyCollection: ОК" & vbCrLf


    ' ========================================================
    ' ПОЛУЧАЕМ КОЛИЧЕСТВО
    '
    ' НЕ Count !!!
    ' Используем GetCount()
    ' ========================================================

    CountBodies = -1

    On Error Resume Next

    Err.Clear

    CountBodies = Bodies.GetCount

    If Err.Number <> 0 Then

        Report = Report & _
                 "GetCount: ОШИБКА " & _
                 Err.Number & _
                 " - " & _
                 Err.Description & vbCrLf

        Err.Clear

    Else

        Report = Report & _
                 "GetCount: ОК" & vbCrLf & _
                 "Количество тел: " & _
                 CountBodies & vbCrLf

    End If

    On Error GoTo FatalError


    If CountBodies <= 0 Then

        MsgBox _
            Report & vbCrLf & _
            "Тел не найдено.", _
            vbExclamation, _
            "Диагностика тел"

        Exit Sub

    End If


    Report = Report & _
             vbCrLf & _
             "================================" & _
             vbCrLf & _
             "СПИСОК ТЕЛ" & _
             vbCrLf & _
             "================================" & _
             vbCrLf & vbCrLf


    ' ========================================================
    ' ПЕРЕБОР ТЕЛ
    '
    ' В API5 пример использует GetByIndex()
    ' ========================================================

    For i = 0 To CountBodies - 1

        Set Body = Nothing
        Set Body7 = Nothing

        NameText = "НЕ ПОЛУЧЕНО"
        MarkingText = "НЕ ПОЛУЧЕНО"
        IdText = "НЕ ПОЛУЧЕН"


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

        On Error Resume Next

        Err.Clear

        Set Body = Bodies.GetByIndex(i)

        If Err.Number <> 0 Then

            Report = Report & _
                     "ТЕЛО №" & (i + 1) & _
                     ": GetByIndex ОШИБКА " & _
                     Err.Number & vbCrLf & vbCrLf

            Err.Clear

            GoTo NextBody

        End If

        On Error GoTo FatalError


        If Body Is Nothing Then

            Report = Report & _
                     "ТЕЛО №" & (i + 1) & _
                     ": ksBody НЕ ПОЛУЧЕН" & _
                     vbCrLf & vbCrLf

            GoTo NextBody

        End If


        ' ----------------------------------------------------
        ' Получаем IBody7
        '
        ' Здесь пока пробуем прямое приведение.
        ' Если не сработает — следующим шагом сделаем
        ' правильный TransferInterface через API5.
        ' ----------------------------------------------------

        On Error Resume Next

        Set Body7 = Body

        On Error GoTo FatalError


        If Body7 Is Nothing Then

            Report = Report & _
                     "ТЕЛО №" & (i + 1) & _
                     ": ksBody ОК" & vbCrLf & _
                     "  IBody7: НЕ ПОЛУЧЕН" & _
                     vbCrLf & vbCrLf

            GoTo NextBody

        End If


        ' ----------------------------------------------------
        ' NAME
        ' ----------------------------------------------------

        On Error Resume Next

        Err.Clear

        NameText = CStr(Body7.Name)

        If Err.Number <> 0 Then

            NameText = "НЕ ПОЛУЧЕНО"
            Err.Clear

        End If


        ' ----------------------------------------------------
        ' MARKING
        ' ----------------------------------------------------

        Err.Clear

        MarkingText = CStr(Body7.Marking)

        If Err.Number <> 0 Then

            MarkingText = "НЕ ПОЛУЧЕНО"
            Err.Clear

        End If


        ' ----------------------------------------------------
        ' BODY ID
        ' ----------------------------------------------------

        Err.Clear

        IdText = CStr(Body7.BodyId)

        If Err.Number <> 0 Then

            IdText = "НЕ ПОЛУЧЕН"
            Err.Clear

        End If

        On Error GoTo FatalError


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

        Report = Report & _
                 "ТЕЛО №" & (i + 1) & vbCrLf & _
                 "  ksBody: ОК" & vbCrLf & _
                 "  IBody7: ОК" & vbCrLf & _
                 "  Name: " & NameText & vbCrLf & _
                 "  Marking: " & MarkingText & vbCrLf & _
                 "  BodyId: " & IdText & _
                 vbCrLf & vbCrLf


NextBody:

    Next i


    ' ========================================================
    ' ПОКАЗ ОТЧЁТА
    ' ========================================================

    ПоказатьОтчетТел _
        "ДИАГНОСТИКА ТЕЛ КОМПАС-3D", _
        Report

    Exit Sub


FatalError:

    MsgBox _
        "Критическая ошибка:" & vbCrLf & vbCrLf & _
        "№ " & Err.Number & vbCrLf & _
        Err.Description, _
        vbCritical, _
        "Диагностика тел"

End Sub


' ============================================================
' ОКНО ОТЧЁТА
' ============================================================

Private Sub ПоказатьОтчетТел( _
    ByVal Заголовок As String, _
    ByVal Текст As String)

    Dim F As Object
    Dim T As Object

    Set F = CreateObject("Forms.UserForm.1")

    F.Caption = Заголовок

    F.Width = 750
    F.Height = 620


    Set T = F.Controls.Add( _
        "Forms.TextBox.1", _
        "txtReport", _
        True)


    With T

        .Left = 10
        .Top = 10

        .Width = 710
        .Height = 550

        .MultiLine = True

        .ScrollBars = 3

        .WordWrap = False

        .Locked = True

        .Font.Name = "Consolas"

        .Font.Size = 9

        .Text = Текст

    End With


    F.Show

End Sub