---

Option Explicit

' ============================================================
' ДИАГНОСТИКА ТЕЛ КОМПАС-3D
'
' Цель:
' ksBody
'   ↓
' ksEntity
'   ↓
' ksFeature
'   ↓
' GetObject
'   ↓
' IBody7
'   ↓
' BodyId / Name / Marking
'
' ============================================================

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

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

    Dim Bodies As Object
    Dim Body5 As Object

    Dim Entity As Object
    Dim Feature As Object
    Dim ObjFromFeature As Object

    Dim Body7 As Object

    Dim CountBodies As Long
    Dim i As Long

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

    On Error GoTo FatalError


    Report = ""

    Report = Report & _
        "==================================================" & vbCrLf & _
        "ДИАГНОСТИКА ТЕЛ КОМПАС-3D" & vbCrLf & _
        "==================================================" & vbCrLf & vbCrLf


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

    Set App5 = Nothing

    On Error Resume Next

    Err.Clear

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

    If App5 Is Nothing Then

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

    End If

    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 & _
            "Количество тел: НЕ ПОЛУЧЕНО" & vbCrLf

        GoTo SaveReport

    End If


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


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

    For i = 0 To CountBodies - 1

        Set Body5 = Nothing
        Set Entity = Nothing
        Set Feature = Nothing
        Set ObjFromFeature = Nothing
        Set Body7 = Nothing


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

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

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


        ' ====================================================
        ' ksBody
        ' ====================================================

        On Error Resume Next

        Err.Clear

        Set Body5 = Bodies.GetByIndex(i)

        If Err.Number <> 0 Then

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

            Err.Clear

        End If

        On Error GoTo FatalError


        If Body5 Is Nothing Then

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

            GoTo NextBody

        End If


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


        ' ====================================================
        ' ksEntity
        ' ====================================================

        On Error Resume Next

        Err.Clear

        Set Entity = Body5

        On Error GoTo FatalError


        If Entity Is Nothing Then

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

            GoTo NextBody

        End If


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


        ' ====================================================
        ' IsIt(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

        If Err.Number <> 0 Then

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

            Err.Clear

        End If

        On Error GoTo FatalError


        ' ====================================================
        ' GetFeature
        ' ====================================================

        On Error Resume Next

        Err.Clear

        Set Feature = Entity.GetFeature

        If Err.Number <> 0 Then

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

            Err.Clear

        End If

        On Error GoTo FatalError


        If Feature Is Nothing Then

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

            GoTo NextBody

        End If


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

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


        ' ====================================================
        ' GetObject У ksFeature
        '
        ' ВОТ ЭТО СЕЙЧАС ГЛАВНАЯ ПРОВЕРКА
        ' ====================================================

        On Error Resume Next

        Err.Clear

        Set ObjFromFeature = Feature.GetObject

        If Err.Number <> 0 Then

            Report = Report & _
                "Feature.GetObject: ОШИБКА " & _
                Err.Number & _
                " / " & _
                Err.Description & vbCrLf

            Err.Clear

        End If

        On Error GoTo FatalError


        If ObjFromFeature Is Nothing Then

            Report = Report & _
                "Feature.GetObject: НЕ ПОЛУЧЕН" & vbCrLf

        Else

            Report = Report & _
                "Feature.GetObject: ОК" & vbCrLf

            Report = Report & _
                "Object TypeName: " & _
                TypeName(ObjFromFeature) & vbCrLf


            ' =================================================
            ' ПРОБУЕМ ПОЛУЧИТЬ IBody7
            '
            ' Через присваивание COM-объекта.
            ' =================================================

            On Error Resume Next

            Err.Clear

            Set Body7 = ObjFromFeature

            If Err.Number <> 0 Then

                Report = Report & _
                    "IBody7 через GetObject: НЕ ПОЛУЧЕН" & vbCrLf

                Report = Report & _
                    "Ошибка: " & _
                    Err.Number & _
                    " / " & _
                    Err.Description & vbCrLf

                Err.Clear

            Else

                If Body7 Is Nothing Then

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

                Else

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


                    ' =========================================
                    ' BodyId
                    ' =========================================

                    Report = Report & _
                        "BodyId: " & _
                        ПрочитатьСвойство(Body7, "BodyId") & _
                        vbCrLf


                    ' =========================================
                    ' Name
                    ' =========================================

                    Report = Report & _
                        "Name: " & _
                        ПрочитатьСвойство(Body7, "Name") & _
                        vbCrLf


                    ' =========================================
                    ' Marking
                    ' =========================================

                    Report = Report & _
                        "Marking: " & _
                        ПрочитатьСвойство(Body7, "Marking") & _
                        vbCrLf


                    ' =========================================
                    ' FileName
                    ' =========================================

                    Report = Report & _
                        "FileName: " & _
                        ПрочитатьСвойство(Body7, "FileName") & _
                        vbCrLf

                End If

            End If

            On Error GoTo FatalError

        End If


        ' ====================================================
        ' ДОПОЛНИТЕЛЬНО:
        ' пробуем свойства самого ksBody
        ' ====================================================

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


        Report = Report & _
            "  Name: " & _
            ПрочитатьСвойство(Body5, "Name") & _
            vbCrLf


        Report = Report & _
            "  Marking: " & _
            ПрочитатьСвойство(Body5, "Marking") & _
            vbCrLf


        Report = Report & _
            "  FileName: " & _
            ПрочитатьСвойство(Body5, "FileName") & _
            vbCrLf


NextBody:

        Set Body5 = Nothing
        Set Entity = Nothing
        Set Feature = Nothing
        Set ObjFromFeature = Nothing
        Set Body7 = 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

        ПрочитатьСвойство = _
            "НЕ ПОЛУЧЕНО (" & _
            Err.Number & _
            ")"


        Err.Clear

        On Error GoTo 0

        Exit Function

    End If


    If IsNull(V) Then

        ПрочитатьСвойство = "NULL"

    ElseIf IsEmpty(V) Then

        ПрочитатьСвойство = "EMPTY"

    ElseIf IsObject(V) Then

        ПрочитатьСвойство = _
            "[OBJECT " & _
            TypeName(V) & _
            "]"

    Else

        ПрочитатьСвойство = CStr(V)

    End If


    On Error GoTo 0

End Function