---

Option Explicit

' ============================================================
' ДИАГНОСТИКА ТЕЛ КОМПАС-3D
'
' Проверяет:
' API5
' ActiveDocument3D
' GetPart(-1)
' TransferInterface -> ksPart
' BodyCollection
' ksBody
' IBody7
' Свойства тела
'
' ОСОБЕННО ДЛЯ:
' - Металлоконструкций
' - Трубопроводов
' - Локальных тел в сборке
' ============================================================

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

    Dim App5 As Object
    Dim App7 As Object

    Dim Doc5 As Object
    Dim Doc7 As Object

    Dim Part5 As Object
    Dim TopPart7 As Object

    Dim BodyCollection As Object
    Dim Body As Object
    Dim Body7 As Object

    Dim PropMng As Object
    Dim PropertyKeeper As Object

    Dim PropMarking As Object
    Dim PropName As Object

    Dim ValueMarking As Variant
    Dim ValueName As Variant

    Dim FromSource As Boolean

    Dim i As Long
    Dim CountBodies As Long

    Dim Report As String
    Dim BodyName As String

    On Error GoTo FatalError


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

    Report = _
        "=== ДИАГНОСТИКА ТЕЛ ===" & _
        vbCrLf & vbCrLf

    Set App5 = Nothing

    On Error Resume Next

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

    On Error GoTo FatalError

    If App5 Is Nothing Then

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

        Exit Sub

    End If

    Report = Report & _
        "API5: OK" & vbCrLf


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

    Set App7 = Nothing

    On Error Resume Next

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

    On Error GoTo FatalError

    If App7 Is Nothing Then

        Report = Report & _
            "API7: НЕ ПОЛУЧЕН" & vbCrLf

    Else

        Report = Report & _
            "API7: OK" & vbCrLf

    End If


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

    Set Doc5 = Nothing

    On Error Resume Next

    Set Doc5 = App5.ActiveDocument3D

    On Error GoTo FatalError

    If Doc5 Is Nothing Then

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

        Exit Sub

    End If

    Report = Report & _
        "ActiveDocument3D: OK" & vbCrLf


    ' ========================================================
    ' ROOT PART
    ' ========================================================

    Set Part5 = Nothing

    On Error Resume Next

    Set Part5 = Doc5.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


    ' ========================================================
    ' API7 DOCUMENT / TOP PART
    ' ========================================================

    Set Doc7 = Nothing
    Set TopPart7 = Nothing

    If Not App7 Is Nothing Then

        On Error Resume Next

        Set Doc7 = App7.ActiveDocument

        On Error GoTo FatalError

        If Not Doc7 Is Nothing Then

            On Error Resume Next

            Set TopPart7 = Doc7.TopPart

            On Error GoTo FatalError

        End If

    End If


    If TopPart7 Is Nothing Then

        Report = Report & _
            "API7 TopPart: НЕ ПОЛУЧЕН" & vbCrLf

    Else

        Report = Report & _
            "API7 TopPart: OK" & vbCrLf

    End If


    ' ========================================================
    ' BODY COLLECTION
    '
    ' ВАЖНО:
    ' НЕ используем GetModelContainer.
    ' ========================================================

    Set BodyCollection = Nothing

    On Error Resume Next

    Set BodyCollection = Part5.BodyCollection

    On Error GoTo FatalError

    If BodyCollection Is Nothing Then

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

        Exit Sub

    End If

    Report = Report & _
        "BodyCollection: OK" & vbCrLf


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

    CountBodies = 0

    On Error Resume Next

    CountBodies = BodyCollection.GetCount

    On Error GoTo FatalError

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


    If CountBodies <= 0 Then

        MsgBox _
            Report & _
            vbCrLf & _
            "В корневой сборке тела не найдены.", _
            vbInformation, _
            "Диагностика"

        Exit Sub

    End If


    ' ========================================================
    ' PROPERTY MANAGER
    ' ========================================================

    Set PropMng = Nothing

    If Not App7 Is Nothing Then

        On Error Resume Next

        Set PropMng = App7

        On Error GoTo FatalError

    End If


    ' ========================================================
    ' ПОЛУЧАЕМ СВОЙСТВА
    ' ========================================================

    Set PropMarking = Nothing
    Set PropName = Nothing

    If Not PropMng Is Nothing And Not Doc7 Is Nothing Then

        On Error Resume Next

        Set PropMarking = _
            PropMng.GetProperty(Doc7, "Обозначение")

        Set PropName = _
            PropMng.GetProperty(Doc7, "Наименование")

        On Error GoTo FatalError

    End If


    ' ========================================================
    ' ПЕРЕБОР ТЕЛ
    ' ========================================================

    For i = 0 To CountBodies - 1

        Set Body = Nothing

        On Error Resume Next

        Set Body = _
            BodyCollection.GetByIndex(i)

        On Error GoTo FatalError


        If Not Body Is Nothing Then

            Report = Report & _
                "----------------------------------------" & _
                vbCrLf

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


            ' =================================================
            ' ИМЯ ksBody
            ' =================================================

            BodyName = ""

            On Error Resume Next

            BodyName = CStr(Body.Name)

            On Error GoTo FatalError

            If Len(BodyName) = 0 Then

                BodyName = "(имя не получено)"

            End If

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


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

            Set Body7 = Nothing

            If Not App5 Is Nothing Then

                On Error Resume Next

                ' ksAPI7Dual = 1
                Set Body7 = _
                    App5.TransferInterface(Body, 1, 0)

                On Error GoTo FatalError

            End If


            If Body7 Is Nothing Then

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

            Else

                Report = Report & _
                    "IBody7: OK" & vbCrLf


                ' =============================================
                ' IPropertyKeeper
                ' =============================================

                Set PropertyKeeper = Nothing

                On Error Resume Next

                Set PropertyKeeper = Body7

                On Error GoTo FatalError


                If PropertyKeeper Is Nothing Then

                    Report = Report & _
                        "IPropertyKeeper: НЕ ПОЛУЧЕН" & vbCrLf

                Else

                    Report = Report & _
                        "IPropertyKeeper: OK" & vbCrLf


                    ' =========================================
                    ' ОБОЗНАЧЕНИЕ
                    ' =========================================

                    ValueMarking = Empty
                    FromSource = False

                    If Not PropMarking Is Nothing Then

                        On Error Resume Next

                        Err.Clear

                        PropertyKeeper.GetPropertyValue _
                            PropMarking, _
                            ValueMarking, _
                            False, _
                            FromSource

                        If Err.Number <> 0 Then

                            Err.Clear

                            Report = Report & _
                                "Обозначение: ошибка чтения" & _
                                vbCrLf

                        Else

                            Report = Report & _
                                "Обозначение: " & _
                                SafeText(ValueMarking) & _
                                vbCrLf

                        End If

                        On Error GoTo FatalError

                    Else

                        Report = Report & _
                            "Свойство ""Обозначение"" не найдено" & _
                            vbCrLf

                    End If


                    ' =========================================
                    ' НАИМЕНОВАНИЕ
                    ' =========================================

                    ValueName = Empty
                    FromSource = False

                    If Not PropName Is Nothing Then

                        On Error Resume Next

                        Err.Clear

                        PropertyKeeper.GetPropertyValue _
                            PropName, _
                            ValueName, _
                            False, _
                            FromSource

                        If Err.Number <> 0 Then

                            Err.Clear

                            Report = Report & _
                                "Наименование: ошибка чтения" & _
                                vbCrLf

                        Else

                            Report = Report & _
                                "Наименование: " & _
                                SafeText(ValueName) & _
                                vbCrLf

                        End If

                        On Error GoTo FatalError

                    Else

                        Report = Report & _
                            "Свойство ""Наименование"" не найдено" & _
                            vbCrLf

                    End If

                End If

            End If

        End If

    Next i


    ' ========================================================
    ' ВЫВОД
    ' ========================================================

    Report = Report & _
        vbCrLf & _
        "========================================" & _
        vbCrLf & _
        "ДИАГНОСТИКА ЗАВЕРШЕНА"


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

    Exit Sub


' ============================================================
' ОШИБКА
' ============================================================

FatalError:

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

End Sub


' ============================================================
' БЕЗОПАСНОЕ ПРЕОБРАЗОВАНИЕ
' ============================================================

Private Function SafeText(ByVal Value As Variant) As String

    On Error GoTo ErrHandler

    If IsEmpty(Value) Then

        SafeText = ""

    ElseIf IsNull(Value) Then

        SafeText = ""

    Else

        SafeText = CStr(Value)

    End If

    Exit Function


ErrHandler:

    SafeText = "(ошибка значения)"

End Function