---

Option Explicit

Public Sub ТестПолученияModelContainer()

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

    Dim Msg As String

    On Error GoTo Ошибка


    Msg = "ШАГ 1" & vbCrLf


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

    Set App5 = GetObject(, "KOMPAS.Application.5")

    If App5 Is Nothing Then

        MsgBox _
            "Не удалось получить KOMPAS.Application.5", _
            vbCritical

        Exit Sub

    End If

    Msg = Msg & "API5 получен" & vbCrLf


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

    Set Doc3D = App5.ActiveDocument3D

    If Doc3D Is Nothing Then

        MsgBox _
            Msg & vbCrLf & _
            "ActiveDocument3D НЕ получен.", _
            vbExclamation

        Exit Sub

    End If

    Msg = Msg & "ActiveDocument3D получен" & vbCrLf


    ' ========================================================
    ' ROOT PART
    '
    ' -1 = сама сборка
    ' ========================================================

    Set Part5 = Doc3D.GetPart(-1)

    If Part5 Is Nothing Then

        MsgBox _
            Msg & vbCrLf & _
            "GetPart(-1) НЕ получил корневую сборку.", _
            vbExclamation

        Exit Sub

    End If

    Msg = Msg & "GetPart(-1) получен" & vbCrLf


    ' ========================================================
    ' ПРОБУЕМ ПОЛУЧИТЬ IPart7
    ' ========================================================

    Set Part7 = Nothing

    On Error Resume Next

    Set Part7 = Part5

    On Error GoTo Ошибка


    If Part7 Is Nothing Then

        MsgBox _
            Msg & vbCrLf & _
            "IPart7 НЕ получен.", _
            vbExclamation

        Exit Sub

    End If

    Msg = Msg & "IPart7 получен" & vbCrLf


    ' ========================================================
    ' MODEL CONTAINER
    ' ========================================================

    Set Container = Nothing

    On Error Resume Next

    Set Container = Part7.GetModelContainer

    On Error GoTo Ошибка


    If Container Is Nothing Then

        MsgBox _
            Msg & vbCrLf & _
            "GetModelContainer НЕ получил контейнер.", _
            vbExclamation

        Exit Sub

    End If


    Msg = Msg & "ModelContainer ПОЛУЧЕН!" & vbCrLf


    ' ========================================================
    ' GET OBJECTS
    ' ========================================================

    Dim Objects As Object

    Set Objects = Nothing

    On Error Resume Next

    Set Objects = Container.GetObjects

    On Error GoTo Ошибка


    If Objects Is Nothing Then

        Msg = Msg & _
            "GetObjects не получил коллекцию." & vbCrLf

    Else

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

        Msg = Msg & _
            "Количество объектов: " & _
            Objects.Count & vbCrLf

    End If


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

    Dim Bodies As Object

    Set Bodies = Nothing

    On Error Resume Next

    Set Bodies = Container.ElementaryBodies

    On Error GoTo Ошибка


    If Bodies Is Nothing Then

        Msg = Msg & _
            "ElementaryBodies НЕ получены." & vbCrLf

    Else

        Msg = Msg & _
            "ElementaryBodies ПОЛУЧЕНЫ" & vbCrLf

        Msg = Msg & _
            "Количество тел: " & _
            Bodies.Count & vbCrLf

    End If


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

    Dim Pipes As Object

    Set Pipes = Nothing

    On Error Resume Next

    Set Pipes = Container.PipeElements

    On Error GoTo Ошибка


    If Pipes Is Nothing Then

        Msg = Msg & _
            "PipeElements НЕ получены." & vbCrLf

    Else

        Msg = Msg & _
            "PipeElements ПОЛУЧЕНЫ" & vbCrLf

        Msg = Msg & _
            "Количество труб: " & _
            Pipes.Count & vbCrLf

    End If


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

    MsgBox _
        Msg & vbCrLf & _
        "ТЕСТ ЗАВЕРШЁН", _
        vbInformation, _
        "Диагностика КОМПАС-3D"

    Exit Sub


Ошибка:

    MsgBox _
        Msg & vbCrLf & vbCrLf & _
        "ОШИБКА:" & vbCrLf & _
        Err.Number & vbCrLf & _
        Err.Description, _
        vbCritical, _
        "Ошибка диагностики"

End Sub