---

Option Explicit

' ============================================================
' ДИАГНОСТИКА ТЕЛ КОМПАС-3D
'
' Результат автоматически сохраняется во временный TXT
' и открывается в Блокноте.
'
' Ничего в модели КОМПАС-3D не изменяет.
' ============================================================

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

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

    Dim CountBodies As Long
    Dim i As Long

    Dim Report As String
    Dim FilePath As String
    Dim FileNum As Integer

    Dim NameText As String
    Dim MarkingText As String
    Dim FileNameText As String
    Dim TypeText As String

    Dim ErrNum As Long
    Dim ErrDesc As String

    On Error GoTo FatalError


    ' ========================================================
    ' НАЧАЛО
    ' ========================================================

    Report = ""

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

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

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


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

    Set App5 = Nothing

    On Error Resume Next

    Err.Clear

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

    ErrNum = Err.Number
    ErrDesc = Err.Description

    Err.Clear

    On Error GoTo FatalError


    If App5 Is Nothing Then

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

        Report = Report & _
            "Ошибка: " & ErrNum & vbCrLf

        Report = Report & _
            "Описание: " & ErrDesc & vbCrLf

        GoTo SaveReport

    Else

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

    End If


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

    Set Doc3D = Nothing

    On Error Resume Next

    Err.Clear

    Set Doc3D = App5.ActiveDocument3D

    ErrNum = Err.Number
    ErrDesc = Err.Description

    Err.Clear

    On Error GoTo FatalError


    If Doc3D Is Nothing Then

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

        Report = Report & _
            "Ошибка: " & ErrNum & vbCrLf

        Report = Report & _
            "Описание: " & ErrDesc & vbCrLf

        GoTo SaveReport

    Else

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

    End If


    ' ========================================================
    ' GETPART(-1)
    '
    ' -1 = головная часть активного документа
    ' ========================================================

    Set Part5 = Nothing

    On Error Resume Next

    Err.Clear

    Set Part5 = Doc3D.GetPart(-1)

    ErrNum = Err.Number
    ErrDesc = Err.Description

    Err.Clear

    On Error GoTo FatalError


    If Part5 Is Nothing Then

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

        Report = Report & _
            "Ошибка: " & ErrNum & vbCrLf

        Report = Report & _
            "Описание: " & ErrDesc & vbCrLf

        GoTo SaveReport

    Else

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

    End If


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

    Set Bodies = Nothing

    On Error Resume Next

    Err.Clear

    Set Bodies = Part5.BodyCollection

    ErrNum = Err.Number
    ErrDesc = Err.Description

    Err.Clear

    On Error GoTo FatalError


    If Bodies Is Nothing Then

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

        Report = Report & _
            "Ошибка: " & ErrNum & vbCrLf

        Report = Report & _
            "Описание: " & ErrDesc & vbCrLf

        GoTo SaveReport

    Else

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

    End If


    ' ========================================================
    ' КОЛИЧЕСТВО ТЕЛ
    '
    ' Используем GetCount()
    ' ========================================================

    CountBodies = -1

    On Error Resume Next

    Err.Clear

    CountBodies = Bodies.GetCount

    ErrNum = Err.Number
    ErrDesc = Err.Description

    Err.Clear

    On Error GoTo FatalError


    If CountBodies < 0 Then

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

        Report = Report & _
            "Ошибка: " & ErrNum & vbCrLf

        Report = Report & _
            "Описание: " & ErrDesc & vbCrLf

        GoTo SaveReport

    Else

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

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

    End If


    ' ========================================================
    ' ЕСЛИ ТЕЛ НЕТ
    ' ========================================================

    If CountBodies = 0 Then

        Report = Report & vbCrLf

        Report = Report & _
            "В коллекции нет тел." & vbCrLf

        GoTo SaveReport

    End If


    ' ========================================================
    ' ЗАГОЛОВОК СПИСКА
    ' ========================================================

    Report = Report & vbCrLf

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

    Report = Report & _
        " СПИСОК ТЕЛ" & vbCrLf

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


    ' ========================================================
    ' ПЕРЕБОР ВСЕХ ТЕЛ
    ' ========================================================

    For i = 0 To CountBodies - 1

        Set Body = Nothing

        NameText = "НЕ ПОЛУЧЕНО"
        MarkingText = "НЕ ПОЛУЧЕНО"
        FileNameText = "НЕ ПОЛУЧЕНО"
        TypeText = "НЕ ПОЛУЧЕН"


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

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

        Report = Report & _
            "Индекс: " & i & vbCrLf


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

        On Error Resume Next

        Err.Clear

        Set Body = Bodies.GetByIndex(i)

        ErrNum = Err.Number
        ErrDesc = Err.Description

        Err.Clear

        On Error GoTo FatalError


        If Body Is Nothing Then

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

            Report = Report & _
                "Ошибка GetByIndex: " & ErrNum & vbCrLf

            Report = Report & _
                "Описание: " & ErrDesc & vbCrLf & vbCrLf

            GoTo NextBody

        Else

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

        End If


        ' ====================================================
        ' ПРОВЕРЯЕМ NAME
        ' ====================================================

        On Error Resume Next

        Err.Clear

        NameText = CStr(Body.Name)

        If Err.Number <> 0 Then

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

            Err.Clear

        End If


        ' ====================================================
        ' ПРОВЕРЯЕМ MARKING
        ' ====================================================

        Err.Clear

        MarkingText = CStr(Body.Marking)

        If Err.Number <> 0 Then

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

            Err.Clear

        End If


        ' ====================================================
        ' ПРОВЕРЯЕМ FILENAME
        ' ====================================================

        Err.Clear

        FileNameText = CStr(Body.FileName)

        If Err.Number <> 0 Then

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

            Err.Clear

        End If


        ' ====================================================
        ' ПРОВЕРЯЕМ TYPE
        ' ====================================================

        Err.Clear

        TypeText = CStr(Body.Type)

        If Err.Number <> 0 Then

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

            Err.Clear

        End If

        On Error GoTo FatalError


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

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

        Report = Report & _
            "Marking: " & MarkingText & vbCrLf

        Report = Report & _
            "FileName: " & FileNameText & vbCrLf

        Report = Report & _
            "Type: " & TypeText & vbCrLf


NextBody:

        Report = Report & vbCrLf

    Next i


    ' ========================================================
    ' КОНЕЦ
    ' ========================================================

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

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

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


' ============================================================
' СОХРАНЕНИЕ В TXT
' ============================================================

SaveReport:

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

    FileNum = FreeFile

    Open FilePath For Output As #FileNum

    Print #FileNum, Report

    Close #FileNum


    ' ========================================================
    ' ОТКРЫВАЕМ БЛОКНОТ
    ' ========================================================

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


    Exit Sub


' ============================================================
' КРИТИЧЕСКАЯ ОШИБКА
' ============================================================

FatalError:

    Report = Report & vbCrLf

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

    Report = Report & _
        " КРИТИЧЕСКАЯ ОШИБКА" & vbCrLf

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

    Report = Report & _
        "Номер: " & Err.Number & vbCrLf

    Report = Report & _
        "Описание: " & Err.Description & vbCrLf


    On Error Resume Next

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

    FileNum = FreeFile

    Open FilePath For Output As #FileNum

    Print #FileNum, Report

    Close #FileNum

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

End Sub