---

Option Explicit

' ============================================================
' ДИАГНОСТИКА ТЕЛ КОМПАС-3D
' Отдельный макрос для запуска через Alt+F8
' ============================================================

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

    Dim App5 As Object
    Dim Doc3D As Object
    Dim Part5 As Object
    Dim Part7 As Object
    Dim BodyCollection As Object
    Dim Body5 As Object
    Dim Body7 As Object

    Dim i As Long
    Dim CountBodies As Long

    Dim Report As String
    Dim NameText As String
    Dim MarkingText As String
    Dim BodyIdText As String
    Dim SolidText As String

    On Error GoTo FatalError

    Report = ""

    ' ========================================================
    ' 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 не получен." & vbCrLf & vbCrLf & _
            "Запусти КОМПАС-3D и открой нужную сборку.", _
            vbCritical, _
            "Диагностика тел"

        Exit Sub

    End If


    Report = Report & _
        "API 5: 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

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

        Exit Sub

    End If


    Report = Report & _
        "ActiveDocument3D: OK" & 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): OK" & vbCrLf


    ' ========================================================
    ' ПОЛУЧАЕМ IPart7
    ' ========================================================

    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: OK" & vbCrLf


    ' ========================================================
    ' ПОЛУЧАЕМ КОЛЛЕКЦИЮ ТЕЛ
    ' ========================================================

    Set BodyCollection = Nothing

    On Error Resume Next

    Set BodyCollection = Part7.Bodies

    If BodyCollection Is Nothing Then

        Set BodyCollection = Part7.ModelContainer

    End If

    On Error GoTo FatalError


    If BodyCollection Is Nothing Then

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

        Exit Sub

    End If


    Report = Report & _
        "Коллекция тел: OK" & vbCrLf


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

    CountBodies = 0

    On Error Resume Next

    CountBodies = BodyCollection.Count

    On Error GoTo FatalError


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


    If CountBodies = 0 Then

        MsgBox _
            Report & _
            "Тел в коллекции нет.", _
            vbInformation, _
            "Диагностика тел"

        Exit Sub

    End If


    ' ========================================================
    ' ПЕРЕБИРАЕМ ТЕЛА
    ' ========================================================

    For i = 0 To CountBodies - 1

        Set Body5 = Nothing
        Set Body7 = Nothing

        NameText = ""
        MarkingText = ""
        BodyIdText = ""
        SolidText = ""


        ' ----------------------------------------------------
        ' Получаем тело
        ' ----------------------------------------------------

        On Error Resume Next

        Set Body5 = BodyCollection.Item(i)

        If Body5 Is Nothing Then

            Set Body5 = BodyCollection.Item(i + 1)

        End If

        On Error GoTo 0


        If Body5 Is Nothing Then

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

            GoTo NextBody

        End If


        ' ----------------------------------------------------
        ' Получаем IBody7
        ' ----------------------------------------------------

        On Error Resume Next

        Set Body7 = Body5

        On Error GoTo 0


        If Body7 Is Nothing Then

            Report = Report & _
                "ТЕЛО №" & (i + 1) & _
                ": 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

        BodyIdText = CStr(Body7.BodyId)

        If Err.Number <> 0 Then

            BodyIdText = "НЕ ПОЛУЧЕН"

            Err.Clear

        End If


        ' ----------------------------------------------------
        ' IS SOLID
        ' ----------------------------------------------------

        Err.Clear

        If Body7.IsSolid Then

            SolidText = "Твердое тело"

        Else

            SolidText = "Оболочка"

        End If

        If Err.Number <> 0 Then

            SolidText = "НЕ ОПРЕДЕЛЕНО"

            Err.Clear

        End If

        On Error GoTo FatalError


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

        Report = Report & _
            "ТЕЛО №" & (i + 1) & vbCrLf & _
            "  Name: " & NameText & vbCrLf & _
            "  Marking: " & MarkingText & vbCrLf & _
            "  BodyId: " & BodyIdText & vbCrLf & _
            "  Тип: " & SolidText & vbCrLf & _
            vbCrLf


NextBody:

    Next i


    ' ========================================================
    ' ПОКАЗЫВАЕМ РЕЗУЛЬТАТ
    ' ========================================================

    Call ПоказатьБольшойОтчет( _
        "ДИАГНОСТИКА ТЕЛ КОМПАС-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 = 700
    F.Height = 600


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


    With T

        .Left = 10
        .Top = 10

        .Width = 660
        .Height = 520

        .MultiLine = True

        .ScrollBars = 3

        .WordWrap = False

        .Locked = True

        .Font.Name = "Consolas"

        .Font.Size = 9

        .Text = Текст

    End With


    F.Show

End Sub