---

Option Explicit

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

    Dim App5 As Object
    Dim Doc3D As Object
    Dim Part5 As Object
    Dim Bodies As Object
    Dim Body As Object

    Dim Entity As Object
    Dim Feature As Object
    Dim Parent As Object
    Dim Definition As Object

    Dim CountBodies As Long
    Dim i As Long

    Dim Report As String
    Dim FilePath As String
    Dim F As Integer

    Report = ""

    On Error GoTo FatalError


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

    Set App5 = Nothing

    On Error Resume Next

    Err.Clear

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

    On Error GoTo FatalError


    If App5 Is Nothing Then

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

        GoTo SaveReport

    End If


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


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

    Set Doc3D = Nothing

    On Error Resume Next

    Err.Clear

    Set Doc3D = App5.ActiveDocument3D

    On Error GoTo FatalError


    If Doc3D Is Nothing Then

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

        GoTo SaveReport

    End If


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


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

    Set Part5 = Nothing

    On Error Resume Next

    Err.Clear

    Set Part5 = Doc3D.GetPart(-1)

    On Error GoTo FatalError


    If Part5 Is Nothing Then

        Report = Report & _
            "GetPart(-1): НЕ ПОЛУЧЕН" & vbCrLf

        GoTo SaveReport

    End If


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


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

    Set Bodies = Nothing

    On Error Resume Next

    Err.Clear

    Set Bodies = Part5.BodyCollection

    On Error GoTo FatalError


    If Bodies Is Nothing Then

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

        GoTo SaveReport

    End If


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


    ' ========================================================
    ' COUNT
    ' ========================================================

    CountBodies = -1

    On Error Resume Next

    Err.Clear

    CountBodies = Bodies.GetCount

    On Error GoTo FatalError


    If CountBodies < 0 Then

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

        GoTo SaveReport

    End If


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


    ' ========================================================
    ' ТЕЛА
    ' ========================================================

    For i = 0 To CountBodies - 1

        Set Body = Nothing
        Set Entity = Nothing
        Set Feature = Nothing
        Set Parent = Nothing
        Set Definition = Nothing


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

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

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


        ' ====================================================
        ' GETBYINDEX
        ' ====================================================

        On Error Resume Next

        Err.Clear

        Set Body = Bodies.GetByIndex(i)

        If Err.Number <> 0 Then

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

            Err.Clear

            On Error GoTo FatalError

            GoTo NextBody

        End If

        On Error GoTo FatalError


        If Body Is Nothing Then

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

            GoTo NextBody

        End If


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


        ' ====================================================
        ' ПОЛУЧАЕМ СВЯЗАННЫЙ ENTITY
        ' ====================================================

        On Error Resume Next

        Err.Clear

        Set Entity = Body

        If Err.Number <> 0 Then

            Err.Clear

            Set Entity = Nothing

        End If

        On Error GoTo FatalError


        If Entity Is Nothing Then

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

        Else

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


            ' =================================================
            ' GETFEATURE
            ' =================================================

            On Error Resume Next

            Err.Clear

            Set Feature = Entity.GetFeature

            On Error GoTo FatalError


            If Feature Is Nothing Then

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

            Else

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

                Report = Report & _
                    "Feature TypeName: " & _
                    TypeName(Feature) & _
                    vbCrLf

            End If


            ' =================================================
            ' GETPARENT
            ' =================================================

            On Error Resume Next

            Err.Clear

            Set Parent = Entity.GetParent

            On Error GoTo FatalError


            If Parent Is Nothing Then

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

            Else

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

                Report = Report & _
                    "Parent TypeName: " & _
                    TypeName(Parent) & _
                    vbCrLf

            End If


            ' =================================================
            ' GETDEFINITION
            ' =================================================

            On Error Resume Next

            Err.Clear

            Set Definition = Entity.GetDefinition

            On Error GoTo FatalError


            If Definition Is Nothing Then

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

            Else

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

                Report = Report & _
                    "Definition TypeName: " & _
                    TypeName(Definition) & _
                    vbCrLf

            End If


            ' =================================================
            ' ПРОБУЕМ ISIT
            '
            ' 115 = o3d_body
            ' =================================================

            On Error Resume Next

            Err.Clear

            If Entity.IsIt(115) Then

                Report = Report & _
                    "IsIt(o3d_body=115): TRUE" & _
                    vbCrLf

            Else

                Report = Report & _
                    "IsIt(o3d_body=115): FALSE" & _
                    vbCrLf

            End If

            Err.Clear

            On Error GoTo FatalError

        End If


        ' ====================================================
        ' ПРЯМЫЕ СВОЙСТВА ksBody
        '
        ' Не предполагаем, что они существуют.
        ' Только проверяем.
        ' ====================================================

        Report = Report & vbCrLf & _
            "Свойства ksBody:" & vbCrLf


        Report = Report & _
            "  Name = " & _
            ДиагностическаяСтрока(Body, "Name") & _
            vbCrLf


        Report = Report & _
            "  Marking = " & _
            ДиагностическаяСтрока(Body, "Marking") & _
            vbCrLf


        Report = Report & _
            "  FileName = " & _
            ДиагностическаяСтрока(Body, "FileName") & _
            vbCrLf


        Report = Report & _
            "  Owner = " & _
            ДиагностическийОбъект(Body, "Owner") & _
            vbCrLf


        Report = Report & _
            "  Feature = " & _
            ДиагностическийОбъект(Body, "Feature") & _
            vbCrLf


        Report = Report & _
            "  Parent = " & _
            ДиагностическийОбъект(Body, "Parent") & _
            vbCrLf


        Report = Report & vbCrLf


NextBody:

        Set Body = Nothing
        Set Entity = Nothing
        Set Feature = Nothing
        Set Parent = Nothing
        Set Definition = Nothing

        DoEvents

    Next i


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


SaveReport:

    FilePath = _
        Environ$("TEMP") & _
        "\Kompas_Body_Diagnostic.txt"


    F = FreeFile

    Open FilePath For Output As #F

    Print #F, Report

    Close #F


    Shell _
        "notepad.exe " & _
        Chr$(34) & _
        FilePath & _
        Chr$(34), _
        vbNormalFocus


    Exit Sub


FatalError:

    Report = Report & _
        vbCrLf & _
        "==================================================" & vbCrLf & _
        "КРИТИЧЕСКАЯ ОШИБКА" & vbCrLf & _
        "Номер: " & Err.Number & vbCrLf & _
        "Описание: " & Err.Description & vbCrLf


    On Error Resume Next

    FilePath = _
        Environ$("TEMP") & _
        "\Kompas_Body_Diagnostic.txt"


    F = FreeFile

    Open FilePath For Output As #F

    Print #F, Report

    Close #F


    Shell _
        "notepad.exe " & _
        Chr$(34) & _
        FilePath & _
        Chr$(34), _
        vbNormalFocus

End Sub


' ============================================================
' БЕЗОПАСНОЕ ЧТЕНИЕ ЗНАЧЕНИЯ
' ============================================================

Private Function ДиагностическаяСтрока( _
    ByVal Obj As Object, _
    ByVal PropertyName As String) As String

    Dim V As Variant

    ДиагностическаяСтрока = "НЕТ"


    If Obj Is Nothing Then Exit Function


    On Error Resume Next

    Err.Clear

    V = CallByName( _
        Obj, _
        PropertyName, _
        VbGet)


    If Err.Number = 0 Then

        If IsNull(V) Then

            ДиагностическаяСтрока = "NULL"

        ElseIf IsEmpty(V) Then

            ДиагностическаяСтрока = "EMPTY"

        ElseIf IsObject(V) Then

            ДиагностическаяСтрока = "[OBJECT]"

        Else

            ДиагностическаяСтрока = CStr(V)

        End If

    Else

        ДиагностическаяСтрока = _
            "НЕТ (" & _
            Err.Number & _
            ")"

        Err.Clear

    End If

    On Error GoTo 0

End Function


' ============================================================
' БЕЗОПАСНОЕ ПОЛУЧЕНИЕ ОБЪЕКТА
' ============================================================

Private Function ДиагностическийОбъект( _
    ByVal Obj As Object, _
    ByVal PropertyName As String) As String

    Dim V As Object

    ДиагностическийОбъект = "НЕТ"


    If Obj Is Nothing Then Exit Function


    On Error Resume Next

    Err.Clear

    Set V = CallByName( _
        Obj, _
        PropertyName, _
        VbGet)


    If Err.Number = 0 Then

        If V Is Nothing Then

            ДиагностическийОбъект = "Nothing"

        Else

            ДиагностическийОбъект = _
                "OK [" & _
                TypeName(V) & _
                "]"

        End If

    Else

        ДиагностическийОбъект = _
            "НЕТ (" & _
            Err.Number & _
            ")"

        Err.Clear

    End If

    On Error GoTo 0

End Function