---

Option Explicit

' ============================================================================
' Макрос SolidWorks 2023 VBA
' Назначение:
'   1. В главной сборке читаются два выбранных размера:
'        - 1-й выбранный размер = ширина;
'        - 2-й выбранный размер = высота.
'   2. Выбирается одна подсборка верхнего уровня.
'   3. В файле подсборки создаётся/используется конфигурация:
'        ширина x высота
'      В новой конфигурации подсборки:
'        D2@LENGHT = ширина;
'        D1@LENGHT = высота.
'   4. Для каждой непосредственной детали подсборки создаётся/используется
'      конфигурация, имя которой строится по фактическим значениям после
'      перестроения:
'        D7@LENGHT x D8@LENGHT
'      Временная конфигурация создаётся от Proba, в ней:
'        D2@LENGHT = ширина;
'        D1@LENGHT = высота.
'   5. Конфигурации назначаются только выбранному экземпляру подсборки и
'      деталям внутри её новой конфигурации. Другие экземпляры подсборок
'      в главной сборке не переключаются.
'
' Важно:
'   - Встроенный редактор SolidWorks VBA обычно уже содержит ссылки на:
'       SolidWorks <версия> Type Library;
'       SolidWorks Constant type library (swconst).
'   - Внешние ссылки и Microsoft Scripting Runtime не используются.
'   - Компоненты должны быть внешними сохранёнными файлами и разрешёнными
'     (resolved). Виртуальные компоненты и подавленные компоненты выдаются
'     как ошибка.
' ============================================================================

Private Const DETAIL_BASE_CONFIGURATION As String = "Proba"
Private Const SKETCH_NAME As String = "LENGHT"

Private Const SUBASSEMBLY_HEIGHT_DIM As String = "D1@LENGHT"
Private Const SUBASSEMBLY_WIDTH_DIM As String = "D2@LENGHT"

Private Const DETAIL_HEIGHT_DIM As String = "D1@LENGHT"
Private Const DETAIL_WIDTH_DIM As String = "D2@LENGHT"
Private Const DETAIL_NAME_WIDTH_DIM As String = "D7@LENGHT"
Private Const DETAIL_NAME_HEIGHT_DIM As String = "D8@LENGHT"

' Разделитель имени конфигурации. При необходимости можно заменить на " х ".
Private Const CONFIG_NAME_SEPARATOR As String = " x "

' -----------------------------------------------------------------------------
' Основная процедура. Имя main используется встроенным редактором макросов.
' -----------------------------------------------------------------------------
Public Sub main()
    Dim swApp As SldWorks.SldWorks
    Dim swAssemblyModel As SldWorks.ModelDoc2
    Dim swSelectionMgr As SldWorks.SelectionMgr
    Dim swSubassemblyComponent As SldWorks.Component2

    Dim widthSystemValue As Double
    Dim heightSystemValue As Double
    Dim subassemblyConfigurationName As String
    Dim report As String
    Dim selectionMessage As String
    Dim ok As Boolean
    Dim saveErrors As Long
    Dim saveWarnings As Long

    On Error GoTo FatalError

    Set swApp = Application.SldWorks
    If swApp Is Nothing Then
        MsgBox "Не удалось получить объект SolidWorks.", vbCritical, "Макрос сетки"
        Exit Sub
    End If

    Set swAssemblyModel = swApp.ActiveDoc
    If swAssemblyModel Is Nothing Then
        MsgBox "Нет активного документа. Откройте главную сборку.", vbExclamation, "Макрос сетки"
        Exit Sub
    End If

    If swAssemblyModel.GetType <> swDocASSEMBLY Then
        MsgBox "Активный документ не является сборкой." & vbCrLf & _
               "Откройте главную сборку и повторите запуск.", _
               vbExclamation, "Макрос сетки"
        Exit Sub
    End If

    Set swSelectionMgr = swAssemblyModel.SelectionManager

    ' Требуется ровно два размера и одна подсборка.
    ok = ReadMainAssemblySelection(swAssemblyModel, swSelectionMgr, _
                                    widthSystemValue, heightSystemValue, _
                                    swSubassemblyComponent, selectionMessage)
    If Not ok Then
        MsgBox selectionMessage, vbExclamation, "Макрос сетки"
        Exit Sub
    End If

    ' Формирование имени конфигурации подсборки по единицам главной сборки.
    subassemblyConfigurationName = BuildConfigurationName(swAssemblyModel, _
                                                           widthSystemValue, _
                                                           heightSystemValue)
    If Len(subassemblyConfigurationName) = 0 Then
        MsgBox "Не удалось сформировать имя конфигурации подсборки.", _
               vbCritical, "Макрос сетки"
        Exit Sub
    End If

    report = "Выбрано:" & vbCrLf & _
             "  Ширина: " & FormatSystemValueForMessage(swAssemblyModel, widthSystemValue) & vbCrLf & _
             "  Высота: " & FormatSystemValueForMessage(swAssemblyModel, heightSystemValue) & vbCrLf & _
             "  Подсборка: " & swSubassemblyComponent.Name2 & vbCrLf & _
             "  Конфигурация подсборки: " & subassemblyConfigurationName & vbCrLf & vbCrLf

    ' Создание конфигураций в подсборке и деталях.
    ok = ProcessSelectedSubassembly(swApp, swAssemblyModel, _
                                     swSubassemblyComponent, _
                                     widthSystemValue, heightSystemValue, _
                                     subassemblyConfigurationName, report)
    If Not ok Then
        MsgBox "Операция остановлена." & vbCrLf & vbCrLf & report, _
               vbCritical, "Макрос сетки"
        Exit Sub
    End If

    ' Назначение конфигурации только выбранному экземпляру подсборки.
    ' Это не переключает другие одинаковые подсборки в главной сборке.
    swSubassemblyComponent.ReferencedConfiguration = subassemblyConfigurationName

    ' Обновляем главную сборку и сохраняем её.
    swAssemblyModel.EditRebuild3
    swAssemblyModel.ForceRebuild3 True

    ok = swAssemblyModel.Save3(swSaveAsOptions_Silent, saveErrors, saveWarnings)
    If Not ok Then
        AddReport report, "ПРЕДУПРЕЖДЕНИЕ: главная сборка не сохранена. Код ошибки Save3: " & CStr(saveErrors)
    Else
        AddReport report, "Главная сборка сохранена."
    End If

    swAssemblyModel.ClearSelection2 True
    MsgBox "Готово." & vbCrLf & vbCrLf & report, vbInformation, "Макрос сетки"
    Exit Sub

FatalError:
    AddReport report, "Критическая ошибка VBA/API: " & Err.Number & " — " & Err.Description
    MsgBox report, vbCritical, "Макрос сетки"
End Sub

' -----------------------------------------------------------------------------
' Чтение выбора в главной сборке.
' Ожидаемый порядок выбора:
'   1) размер ширины;
'   2) размер высоты;
'   3) подсборка.
' Для совместного выбора удерживайте Ctrl.
' -----------------------------------------------------------------------------
Private Function ReadMainAssemblySelection( _
    ByVal swAssemblyModel As SldWorks.ModelDoc2, _
    ByVal swSelectionMgr As SldWorks.SelectionMgr, _
    ByRef widthSystemValue As Double, _
    ByRef heightSystemValue As Double, _
    ByRef selectedSubassembly As SldWorks.Component2, _
    ByRef errorMessage As String) As Boolean

    Dim selectedCount As Long
    Dim i As Long
    Dim selectionType As Long
    Dim dimensionCount As Long
    Dim componentCount As Long
    Dim displayDimension As SldWorks.DisplayDimension
    Dim dimension As SldWorks.Dimension
    Dim selectedComponent As SldWorks.Component2
    Dim componentModel As SldWorks.ModelDoc2
    Dim componentPath As String

    On Error GoTo SelectionError

    selectedCount = swSelectionMgr.GetSelectedObjectCount2(-1)
    If selectedCount <> 3 Then
        errorMessage = "Нужно выбрать ровно 3 объекта в главной сборке:" & vbCrLf & _
                       "1) размер ширины;" & vbCrLf & _
                       "2) размер высоты;" & vbCrLf & _
                       "3) одну подсборку." & vbCrLf & vbCrLf & _
                       "Для множественного выбора удерживайте Ctrl."
        Exit Function
    End If

    For i = 1 To selectedCount
        selectionType = swSelectionMgr.GetSelectedObjectType3(i, -1)

        If selectionType = swSelDIMENSIONS Then
            dimensionCount = dimensionCount + 1

            Set displayDimension = swSelectionMgr.GetSelectedObject6(i, -1)
            If displayDimension Is Nothing Then
                errorMessage = "Не удалось получить выбранный размер №" & CStr(dimensionCount) & "."
                Exit Function
            End If

            Set dimension = displayDimension.GetDimension2(0)
            If dimension Is Nothing Then
                errorMessage = "Не удалось получить модельный размер №" & CStr(dimensionCount) & "."
                Exit Function
            End If

            If dimensionCount = 1 Then
                ' По условию первый выбранный размер — ширина.
                widthSystemValue = ReadDimensionSystemValue(dimension)
            ElseIf dimensionCount = 2 Then
                ' По условию второй выбранный размер — высота.
                heightSystemValue = ReadDimensionSystemValue(dimension)
            End If

        ElseIf selectionType = swSelCOMPONENTS Then
            componentCount = componentCount + 1
            Set selectedComponent = swSelectionMgr.GetSelectedObjectsComponent4(i, -1)

            If selectedComponent Is Nothing Then
                errorMessage = "Не удалось получить выбранный компонент подсборки."
                Exit Function
            End If

            If componentCount > 1 Then
                errorMessage = "Выбрано более одной подсборки. Оставьте только одну подсборку."
                Exit Function
            End If

            Set selectedSubassembly = selectedComponent
        Else
            errorMessage = "Среди выбранных объектов есть объект неподдерживаемого типа." & vbCrLf & _
                           "Нужны только два размера и один компонент-подсборка."
            Exit Function
        End If
    Next i

    If dimensionCount <> 2 Or componentCount <> 1 Then
        errorMessage = "Не найдено требуемое сочетание выбора: два размера и одна подсборка."
        Exit Function
    End If

    If widthSystemValue <= 0# Or heightSystemValue <= 0# Then
        errorMessage = "Размеры ширины и высоты должны быть больше нуля."
        Exit Function
    End If

    componentPath = selectedSubassembly.GetPathName
    If Len(componentPath) = 0 Then
        errorMessage = "Выбранная подсборка не имеет пути к файлу." & vbCrLf & _
                       "Виртуальные подсборки этим макросом не поддерживаются."
        Exit Function
    End If

    If LCase$(Right$(componentPath, 6)) <> ".sldasm" Then
        errorMessage = "Выбранный компонент не является файлом подсборки (*.SLDASM)."
        Exit Function
    End If

    ' Проверка доступности модельного документа. Для облегчённых компонентов
    ' GetModelDoc2 может вернуть Nothing — в таком случае просим разрешить его.
    Set componentModel = selectedSubassembly.GetModelDoc2
    If componentModel Is Nothing Then
        errorMessage = "Не удалось получить модель выбранной подсборки." & vbCrLf & _
                       "Перед запуском переведите подсборку в состояние Resolved " & _
                       "(не Lightweight и не Suppressed)."
        Exit Function
    End If

    If componentModel.GetType <> swDocASSEMBLY Then
        errorMessage = "Выбранный компонент по пути имеет расширение SLDASM, " & _
                       "но SolidWorks не распознал его как сборку."
        Exit Function
    End If

    ReadMainAssemblySelection = True
    Exit Function

SelectionError:
    errorMessage = "Ошибка при чтении выбора: " & Err.Number & " — " & Err.Description
End Function

' -----------------------------------------------------------------------------
' Обработка выбранной подсборки.
' -----------------------------------------------------------------------------
Private Function ProcessSelectedSubassembly( _
    ByVal swApp As SldWorks.SldWorks, _
    ByVal swAssemblyModel As SldWorks.ModelDoc2, _
    ByVal selectedSubassembly As SldWorks.Component2, _
    ByVal widthSystemValue As Double, _
    ByVal heightSystemValue As Double, _
    ByVal targetConfigurationName As String, _
    ByRef report As String) As Boolean

    Dim subassemblyPath As String
    Dim subassemblyModel As SldWorks.ModelDoc2
    Dim wasAlreadyOpen As Boolean
    Dim openedByMacro As Boolean
    Dim oldConfigurationName As String
    Dim baseConfigurationName As String
    Dim configuration As SldWorks.Configuration
    Dim vChildren As Variant
    Dim child As SldWorks.Component2
    Dim childCount As Long
    Dim partCount As Long
    Dim i As Long
    Dim childName As String
    Dim childPath As String
    Dim childNames() As String
    Dim childPaths() As String
    Dim detailConfigurationName As String
    Dim detailReport As String
    Dim saveErrors As Long
    Dim saveWarnings As Long
    Dim ok As Boolean

    On Error GoTo ProcessError

    subassemblyPath = selectedSubassembly.GetPathName
    If Len(subassemblyPath) = 0 Then
        Err.Raise vbObjectError + 1000, , "У выбранной подсборки отсутствует путь к файлу."
    End If

    Set subassemblyModel = GetOrOpenModel(swApp, subassemblyPath, swDocASSEMBLY, _
                                          wasAlreadyOpen, openedByMacro)
    If subassemblyModel Is Nothing Then
        Err.Raise vbObjectError + 1001, , "Не удалось открыть файл подсборки:" & vbCrLf & subassemblyPath
    End If

    If subassemblyModel.GetType <> swDocASSEMBLY Then
        Err.Raise vbObjectError + 1002, , "Файл выбранной подсборки не является сборкой."
    End If

    oldConfigurationName = GetActiveConfigurationName(subassemblyModel)
    baseConfigurationName = selectedSubassembly.ReferencedConfiguration
    If Len(baseConfigurationName) = 0 Then baseConfigurationName = oldConfigurationName

    Set configuration = subassemblyModel.GetConfigurationByName(targetConfigurationName)

    If Not configuration Is Nothing Then
        ' Если конфигурация уже существует, согласно требованию пользователя
        ' не меняем её размеры и дочерние компоненты — только используем её.
        If Not subassemblyModel.ShowConfiguration2(targetConfigurationName) Then
            Err.Raise vbObjectError + 1003, , _
                      "Не удалось активировать уже существующую конфигурацию подсборки: " & _
                      targetConfigurationName
        End If

        AddReport report, "Конфигурация подсборки уже существовала и не изменялась: " & _
                         targetConfigurationName
        ProcessSelectedSubassembly = True
        GoTo CleanExit
    End If

    If Len(baseConfigurationName) = 0 Then baseConfigurationName = "Default"
    Set configuration = subassemblyModel.GetConfigurationByName(baseConfigurationName)
    If configuration Is Nothing Then
        Err.Raise vbObjectError + 1004, , _
                  "Базовая конфигурация подсборки не найдена: " & baseConfigurationName
    End If

    If Not subassemblyModel.ShowConfiguration2(baseConfigurationName) Then
        Err.Raise vbObjectError + 1005, , _
                  "Не удалось активировать базовую конфигурацию подсборки: " & _
                  baseConfigurationName
    End If

    ' AddConfiguration3 без флага Derived создаёт самостоятельную конфигурацию,
    ' наследующую текущее состояние активной конфигурации.
    Set configuration = subassemblyModel.AddConfiguration3(targetConfigurationName, "", "", 0)
    If configuration Is Nothing Then
        Err.Raise vbObjectError + 1006, , _
                  "Не удалось создать конфигурацию подсборки: " & targetConfigurationName
    End If

    If Not subassemblyModel.ShowConfiguration2(targetConfigurationName) Then
        Err.Raise vbObjectError + 1007, , _
                  "Не удалось активировать новую конфигурацию подсборки: " & _
                  targetConfigurationName
    End If

    ' В новой конфигурации подсборки меняются только два параметра сетки.
    SetDimensionSystemValue subassemblyModel, SUBASSEMBLY_WIDTH_DIM, widthSystemValue, _
                            "подсборке, ширина"
    SetDimensionSystemValue subassemblyModel, SUBASSEMBLY_HEIGHT_DIM, heightSystemValue, _
                            "подсборке, высота"

    subassemblyModel.EditRebuild3
    subassemblyModel.ForceRebuild3 True

    ' Сохраняем имена и пути непосредственных дочерних компонентов заранее.
    ' После переключения ReferencedConfiguration массивы GetChildren могут
    ' стать недействительными, поэтому ниже используются имена компонентов.
    Set configuration = subassemblyModel.GetActiveConfiguration
    If configuration Is Nothing Then
        Err.Raise vbObjectError + 1008, , "Не удалось получить активную конфигурацию подсборки."
    End If

    Set child = configuration.GetRootComponent
    If child Is Nothing Then
        Err.Raise vbObjectError + 1009, , "Не удалось получить корневой компонент подсборки."
    End If

    vChildren = child.GetChildren
    If IsEmpty(vChildren) Then
        Err.Raise vbObjectError + 1010, , "В выбранной подсборке нет дочерних компонентов."
    End If

    childCount = UBound(vChildren) - LBound(vChildren) + 1
    ReDim childNames(1 To childCount)
    ReDim childPaths(1 To childCount)

    For i = LBound(vChildren) To UBound(vChildren)
        Set child = vChildren(i)
        childName = child.Name2
        childPath = child.GetPathName

        If Len(childName) = 0 Then
            Err.Raise vbObjectError + 1011, , "Один из дочерних компонентов не имеет имени."
        End If

        childNames(i - LBound(vChildren) + 1) = childName
        childPaths(i - LBound(vChildren) + 1) = childPath

        If Len(childPath) = 0 Then
            AddReport report, "ПРОПУСК: виртуальный или недоступный компонент " & childName
        ElseIf LCase$(Right$(childPath, 6)) = ".sldprt" Then
            partCount = partCount + 1
        ElseIf LCase$(Right$(childPath, 6)) = ".sldasm" Then
            AddReport report, "ПРОПУСК: вложенная подсборка " & childName & _
                             " (обрабатываются только детали первого уровня)."
        Else
            AddReport report, "ПРОПУСК: неподдерживаемый тип компонента " & childName & _
                             " — " & childPath
        End If
    Next i

    If partCount = 0 Then
        Err.Raise vbObjectError + 1012, , _
                  "В выбранной подсборке не найдено ни одной непосредственной детали (*.SLDPRT)."
    End If

    ' Обрабатываем каждую непосредственную деталь и назначаем конфигурацию
    ' конкретному экземпляру в текущей конфигурации подсборки.
    For i = 1 To childCount
        childName = childNames(i)
        childPath = childPaths(i)

        If LCase$(Right$(childPath, 6)) = ".sldprt" Then
            detailReport = ""
            detailConfigurationName = ""

            ok = ProcessDetailPart(swApp, childPath, widthSystemValue, _
                                   heightSystemValue, detailConfigurationName, _
                                   detailReport)
            If Not ok Then
                If Len(detailReport) > 0 Then AddReport report, detailReport
                Err.Raise vbObjectError + 1013, , _
                          "Не удалось обработать деталь " & childName & "."
            End If

            If Len(detailReport) > 0 Then AddReport report, detailReport

            ok = SetDirectChildReferencedConfiguration(subassemblyModel, childName, _
                                                        detailConfigurationName, detailReport)
            If Not ok Then
                If Len(detailReport) > 0 Then AddReport report, detailReport
                Err.Raise vbObjectError + 1014, , _
                          "Не удалось назначить конфигурацию детали " & childName & "."
            End If

            AddReport report, "  " & childName & " -> " & detailConfigurationName
        End If
    Next i

    subassemblyModel.EditRebuild3
    subassemblyModel.ForceRebuild3 True

    ok = subassemblyModel.Save3(swSaveAsOptions_Silent, saveErrors, saveWarnings)
    If Not ok Then
        Err.Raise vbObjectError + 1015, , _
                  "Не удалось сохранить подсборку. Код Save3: " & CStr(saveErrors) & _
                  vbCrLf & subassemblyPath
    End If

    AddReport report, "Подсборка сохранена: " & subassemblyPath
    ProcessSelectedSubassembly = True

CleanExit:
    On Error Resume Next

    ' Возвращаем открытый ранее документ к его исходной активной конфигурации.
    If wasAlreadyOpen Then
        If Len(oldConfigurationName) > 0 Then
            subassemblyModel.ShowConfiguration2 oldConfigurationName
        End If
    ElseIf openedByMacro Then
        swApp.CloseDoc subassemblyModel.GetTitle
    End If

    On Error GoTo 0
    Exit Function

ProcessError:
    AddReport report, "Ошибка подсборки: " & Err.Number & " — " & Err.Description
    ProcessSelectedSubassembly = False

    On Error Resume Next
    If Not subassemblyModel Is Nothing Then
        If wasAlreadyOpen Then
            If Len(oldConfigurationName) > 0 Then subassemblyModel.ShowConfiguration2 oldConfigurationName
        ElseIf openedByMacro Then
            swApp.CloseDoc subassemblyModel.GetTitle
        End If
    End If
    On Error GoTo 0
End Function

' -----------------------------------------------------------------------------
' Обработка одной детали.
' Если целевая конфигурация уже существует, она не изменяется.
' Чтобы получить её имя по D7/D8 после перестроения, используется временная
' конфигурация. Она удаляется, если целевая конфигурация уже была в файле.
' -----------------------------------------------------------------------------
Private Function ProcessDetailPart( _
    ByVal swApp As SldWorks.SldWorks, _
    ByVal partPath As String, _
    ByVal widthSystemValue As Double, _
    ByVal heightSystemValue As Double, _
    ByRef targetConfigurationName As String, _
    ByRef report As String) As Boolean

    Dim partModel As SldWorks.ModelDoc2
    Dim wasAlreadyOpen As Boolean
    Dim openedByMacro As Boolean
    Dim oldConfigurationName As String
    Dim tempConfigurationName As String
    Dim tempConfiguration As SldWorks.Configuration
    Dim finalConfiguration As SldWorks.Configuration
    Dim d7 As SldWorks.Dimension
    Dim d8 As SldWorks.Dimension
    Dim d7SystemValue As Double
    Dim d8SystemValue As Double
    Dim saveErrors As Long
    Dim saveWarnings As Long
    Dim ok As Boolean
    Dim cleanupConfiguration As SldWorks.Configuration

    On Error GoTo DetailError

    If Len(partPath) = 0 Then
        Err.Raise vbObjectError + 2000, , "Путь к детали пустой."
    End If

    Set partModel = GetOrOpenModel(swApp, partPath, swDocPART, _
                                    wasAlreadyOpen, openedByMacro)
    If partModel Is Nothing Then
        Err.Raise vbObjectError + 2001, , "Не удалось открыть деталь:" & vbCrLf & partPath
    End If

    If partModel.GetType <> swDocPART Then
        Err.Raise vbObjectError + 2002, , "Файл не является деталью: " & partPath
    End If

    oldConfigurationName = GetActiveConfigurationName(partModel)

    Set finalConfiguration = partModel.GetConfigurationByName(DETAIL_BASE_CONFIGURATION)
    If finalConfiguration Is Nothing Then
        Err.Raise vbObjectError + 2003, , _
                  "В детали отсутствует базовая конфигурация " & DETAIL_BASE_CONFIGURATION & "."
    End If

    ' Временная конфигурация создаётся именно от Proba.
    If Not partModel.ShowConfiguration2(DETAIL_BASE_CONFIGURATION) Then
        Err.Raise vbObjectError + 2004, , _
                  "Не удалось активировать конфигурацию " & DETAIL_BASE_CONFIGURATION & "."
    End If

    tempConfigurationName = MakeUniqueTemporaryConfigurationName(partModel)
    Set tempConfiguration = partModel.AddConfiguration3(tempConfigurationName, "", "", 0)
    If tempConfiguration Is Nothing Then
        Err.Raise vbObjectError + 2005, , "Не удалось создать временную конфигурацию детали."
    End If

    If Not partModel.ShowConfiguration2(tempConfigurationName) Then
        Err.Raise vbObjectError + 2006, , "Не удалось активировать временную конфигурацию детали."
    End If

    ' Размеры D1/D2 меняются только в новой временной конфигурации.
    SetDimensionSystemValue partModel, DETAIL_WIDTH_DIM, widthSystemValue, _
                            "детали, ширина"
    SetDimensionSystemValue partModel, DETAIL_HEIGHT_DIM, heightSystemValue, _
                            "детали, высота"

    partModel.EditRebuild3
    partModel.ForceRebuild3 True

    Set d7 = partModel.Parameter(DETAIL_NAME_WIDTH_DIM)
    If d7 Is Nothing Then
        Err.Raise vbObjectError + 2007, , _
                  "В детали не найден размер " & DETAIL_NAME_WIDTH_DIM & "."
    End If

    Set d8 = partModel.Parameter(DETAIL_NAME_HEIGHT_DIM)
    If d8 Is Nothing Then
        Err.Raise vbObjectError + 2008, , _
                  "В детали не найден размер " & DETAIL_NAME_HEIGHT_DIM & "."
    End If

    d7SystemValue = ReadDimensionSystemValue(d7)
    d8SystemValue = ReadDimensionSystemValue(d8)

    ' Имя: фактическая ширина D7 после перестроения x фактическая высота D8.
    targetConfigurationName = BuildConfigurationName(partModel, d7SystemValue, d8SystemValue)
    If Len(targetConfigurationName) = 0 Then
        Err.Raise vbObjectError + 2009, , "Не удалось сформировать имя конфигурации детали."
    End If

    Set finalConfiguration = partModel.GetConfigurationByName(targetConfigurationName)

    If finalConfiguration Is Nothing Then
        ' Целевого имени ещё нет: переименовываем временную конфигурацию.
        Set tempConfiguration = partModel.GetConfigurationByName(tempConfigurationName)
        If tempConfiguration Is Nothing Then
            Err.Raise vbObjectError + 2010, , "Временная конфигурация детали потеряна."
        End If

        tempConfiguration.Name = targetConfigurationName
        AddReport report, "Деталь " & partModel.GetTitle & ": создана конфигурация " & _
                         targetConfigurationName
    Else
        ' Целевая конфигурация уже существовала. Не изменяем её, а удаляем только
        ' временную конфигурацию после выхода из неё.
        If Not partModel.ShowConfiguration2(DETAIL_BASE_CONFIGURATION) Then
            Err.Raise vbObjectError + 2011, , _
                      "Не удалось выйти из временной конфигурации детали."
        End If

        ok = partModel.DeleteConfiguration2(tempConfigurationName)
        If Not ok Then
            Err.Raise vbObjectError + 2012, , _
                      "Не удалось удалить временную конфигурацию детали: " & _
                      tempConfigurationName
        End If

        If Not partModel.ShowConfiguration2(targetConfigurationName) Then
            Err.Raise vbObjectError + 2013, , _
                      "Не удалось активировать существующую конфигурацию детали: " & _
                      targetConfigurationName
        End If

        AddReport report, "Деталь " & partModel.GetTitle & ": конфигурация уже существовала " & _
                         "и не изменялась — " & targetConfigurationName
    End If

    partModel.EditRebuild3
    partModel.ForceRebuild3 True

    ok = partModel.Save3(swSaveAsOptions_Silent, saveErrors, saveWarnings)
    If Not ok Then
        Err.Raise vbObjectError + 2014, , _
                  "Не удалось сохранить деталь. Код Save3: " & CStr(saveErrors) & _
                  vbCrLf & partPath
    End If

    ProcessDetailPart = True

DetailCleanExit:
    On Error Resume Next

    If wasAlreadyOpen Then
        If Len(oldConfigurationName) > 0 Then
            partModel.ShowConfiguration2 oldConfigurationName
        End If
    ElseIf openedByMacro Then
        swApp.CloseDoc partModel.GetTitle
    End If

    On Error GoTo 0
    Exit Function

DetailError:
    AddReport report, "Ошибка детали " & partPath & ": " & Err.Number & " — " & Err.Description
    ProcessDetailPart = False

    ' Пытаемся удалить временную конфигурацию при ошибке, чтобы не оставлять
    ' технические конфигурации в файле.
    On Error Resume Next
    If Not partModel Is Nothing Then
        If Len(tempConfigurationName) > 0 Then
            Set cleanupConfiguration = partModel.GetConfigurationByName(tempConfigurationName)
            If Not cleanupConfiguration Is Nothing Then
                partModel.ShowConfiguration2 DETAIL_BASE_CONFIGURATION
                partModel.DeleteConfiguration2 tempConfigurationName
            End If
        End If

        If wasAlreadyOpen Then
            If Len(oldConfigurationName) > 0 Then partModel.ShowConfiguration2 oldConfigurationName
        ElseIf openedByMacro Then
            swApp.CloseDoc partModel.GetTitle
        End If
    End If
    On Error GoTo 0
End Function

' -----------------------------------------------------------------------------
' Назначение конфигурации конкретному непосредственному компоненту подсборки.
' Поиск выполняется заново после возможного Resolve, потому что SolidWorks
' может сделать ранее полученный массив компонентов недействительным.
' -----------------------------------------------------------------------------
Private Function SetDirectChildReferencedConfiguration( _
    ByVal subassemblyModel As SldWorks.ModelDoc2, _
    ByVal childName As String, _
    ByVal targetConfigurationName As String, _
    ByRef errorMessage As String) As Boolean

    Dim subassemblyConfiguration As SldWorks.Configuration
    Dim rootComponent As SldWorks.Component2
    Dim vChildren As Variant
    Dim child As SldWorks.Component2
    Dim i As Long
    Dim suppressionState As Long
    Dim suppressionResult As Long
    Dim found As Boolean

    On Error GoTo AssignError

    For i = 1 To 2
        Set subassemblyConfiguration = subassemblyModel.GetActiveConfiguration
        If subassemblyConfiguration Is Nothing Then
            errorMessage = "Не удалось получить активную конфигурацию подсборки."
            Exit Function
        End If

        Set rootComponent = subassemblyConfiguration.GetRootComponent
        If rootComponent Is Nothing Then
            errorMessage = "Не удалось получить корневой компонент подсборки."
            Exit Function
        End If

        vChildren = rootComponent.GetChildren
        If IsEmpty(vChildren) Then
            errorMessage = "В активной конфигурации подсборки отсутствуют дочерние компоненты."
            Exit Function
        End If

        found = False
        For Each child In vChildren
            If StrComp(child.Name2, childName, vbBinaryCompare) = 0 Then
                found = True
                suppressionState = child.GetSuppression

                If suppressionState = swComponentSuppressed Then
                    errorMessage = "Компонент " & childName & " подавлен."
                    Exit Function
                End If

                If suppressionState = swComponentLightweight Then
                    ' Переводим только этот компонент в Resolved.
                    suppressionResult = child.SetSuppression2(swComponentFullyResolved)
                    If suppressionResult = 0 Then
                        ' SolidWorks мог вернуть код ошибки; всё равно ниже
                        ' повторно перечитаем объект и проверим его состояние.
                    End If
                    Exit For
                End If

                child.ReferencedConfiguration = targetConfigurationName
                SetDirectChildReferencedConfiguration = True
                Exit Function
            End If
        Next child

        If Not found Then
            errorMessage = "Компонент не найден в активной конфигурации подсборки: " & childName
            Exit Function
        End If

        ' После Resolve начинаем поиск заново.
    Next i

    errorMessage = "Не удалось перевести компонент в Resolved и назначить конфигурацию: " & childName
    Exit Function

AssignError:
    errorMessage = "Ошибка назначения конфигурации компоненту " & childName & ": " & _
                   Err.Number & " — " & Err.Description
End Function

' -----------------------------------------------------------------------------
' Открыть документ, если он ещё не открыт.
' -----------------------------------------------------------------------------
Private Function GetOrOpenModel( _
    ByVal swApp As SldWorks.SldWorks, _
    ByVal filePath As String, _
    ByVal documentType As Long, _
    ByRef wasAlreadyOpen As Boolean, _
    ByRef openedByMacro As Boolean) As SldWorks.ModelDoc2

    Dim model As SldWorks.ModelDoc2
    Dim openErrors As Long
    Dim openWarnings As Long

    On Error GoTo OpenError

    Set model = swApp.GetOpenDocumentByName(filePath)
    If Not model Is Nothing Then
        wasAlreadyOpen = True
        openedByMacro = False
        Set GetOrOpenModel = model
        Exit Function
    End If

    Set model = swApp.OpenDoc6(filePath, documentType, swOpenDocOptions_Silent, "", _
                               openErrors, openWarnings)
    If model Is Nothing Then
        wasAlreadyOpen = False
        openedByMacro = False
        Set GetOrOpenModel = Nothing
        Exit Function
    End If

    wasAlreadyOpen = False
    openedByMacro = True
    Set GetOrOpenModel = model
    Exit Function

OpenError:
    wasAlreadyOpen = False
    openedByMacro = False
    Set GetOrOpenModel = Nothing
End Function

' -----------------------------------------------------------------------------
' Установить размер в текущей конфигурации документа.
' Значение передаётся в системных единицах SolidWorks — метрах.
' -----------------------------------------------------------------------------
Private Sub SetDimensionSystemValue( _
    ByVal model As SldWorks.ModelDoc2, _
    ByVal dimensionName As String, _
    ByVal newSystemValue As Double, _
    ByVal contextName As String)

    Dim dimension As SldWorks.Dimension
    Dim setResult As Long

    Set dimension = model.Parameter(dimensionName)
    If dimension Is Nothing Then
        Err.Raise vbObjectError + 3000, , _
                  "Не найден размер " & dimensionName & " в " & contextName & "."
    End If

    If dimension.ReadOnly Then
        Err.Raise vbObjectError + 3001, , _
                  "Размер " & dimensionName & " доступен только для чтения в " & contextName & "."
    End If

    setResult = dimension.SetSystemValue3(newSystemValue, _
                                          swSetValue_InThisConfiguration, Empty)
    If setResult <> swSetValue_Successful Then
        Err.Raise vbObjectError + 3002, , _
                  "SolidWorks не принял новое значение размера " & dimensionName & _
                  " в " & contextName & ". Код SetSystemValue3: " & CStr(setResult)
    End If
End Sub

' -----------------------------------------------------------------------------
' Системное значение Dimension в метрах.
' GetSystemValue3 возвращает Variant; в некоторых режимах это массив.
' -----------------------------------------------------------------------------
Private Function ReadDimensionSystemValue(ByVal dimension As SldWorks.Dimension) As Double
    Dim value As Variant

    value = dimension.GetSystemValue3(swThisConfiguration, Empty)

    If IsArray(value) Then
        ReadDimensionSystemValue = CDbl(value(LBound(value)))
    Else
        ReadDimensionSystemValue = CDbl(value)
    End If
End Function

' -----------------------------------------------------------------------------
' Сформировать имя конфигурации из значений размеров.
' SolidWorks API хранит длину в метрах, а GetUserUnit переводит её в единицы
' документа (например, mm, cm, inch). Единица измерения в имя не добавляется.
' Десятичный разделитель берётся из региональных настроек Windows через Format$.
' -----------------------------------------------------------------------------
Private Function BuildConfigurationName( _
    ByVal model As SldWorks.ModelDoc2, _
    ByVal firstSystemValue As Double, _
    ByVal secondSystemValue As Double) As String

    Dim firstText As String
    Dim secondText As String

    firstText = FormatSystemValueForConfigName(model, firstSystemValue)
    secondText = FormatSystemValueForConfigName(model, secondSystemValue)

    If Len(firstText) = 0 Or Len(secondText) = 0 Then
        BuildConfigurationName = ""
    Else
        BuildConfigurationName = SanitizeConfigurationName(firstText & _
                                                            CONFIG_NAME_SEPARATOR & _
                                                            secondText)
    End If
End Function

Private Function FormatSystemValueForConfigName( _
    ByVal model As SldWorks.ModelDoc2, _
    ByVal systemValue As Double) As String

    Dim userUnit As SldWorks.UserUnit
    Dim userValue As Double
    Dim text As String

    On Error GoTo FormatError

    Set userUnit = model.GetUserUnit(swLengthUnit)
    If userUnit Is Nothing Then GoTo FormatError

    userValue = systemValue * userUnit.GetConversionFactor

    ' До 8 знаков после запятой, без незначащих нулей.
    text = Format$(userValue, "0.########")
    text = Replace$(text, ChrW$(160), "")
    text = Trim$(text)

    FormatSystemValueForConfigName = text
    Exit Function

FormatError:
    ' Запасной вариант для крайне редких случаев недоступности UserUnit.
    text = Format$(systemValue * 1000#, "0.########")
    FormatSystemValueForConfigName = Trim$(text)
End Function

Private Function FormatSystemValueForMessage( _
    ByVal model As SldWorks.ModelDoc2, _
    ByVal systemValue As Double) As String
    FormatSystemValueForMessage = FormatSystemValueForConfigName(model, systemValue)
End Function

' -----------------------------------------------------------------------------
' Удаление символов, которые SolidWorks не принимает в имени конфигурации.
' -----------------------------------------------------------------------------
Private Function SanitizeConfigurationName(ByVal nameText As String) As String
    Dim result As String

    result = Trim$(nameText)
    result = Replace$(result, "\", "_")
    result = Replace$(result, "/", "_")
    result = Replace$(result, ":", "_")
    result = Replace$(result, "*", "_")
    result = Replace$(result, "?", "_")
    result = Replace$(result, Chr$(34), "_")
    result = Replace$(result, "<", "_")
    result = Replace$(result, ">", "_")
    result = Replace$(result, "|", "_")

    SanitizeConfigurationName = Trim$(result)
End Function

' -----------------------------------------------------------------------------
' Уникальное имя временной конфигурации детали.
' -----------------------------------------------------------------------------
Private Function MakeUniqueTemporaryConfigurationName( _
    ByVal model As SldWorks.ModelDoc2) As String

    Dim baseName As String
    Dim candidate As String
    Dim index As Long
    Dim existingConfiguration As SldWorks.Configuration

    baseName = "__GRID_TMP_" & Format$(Now, "yyyymmdd_hhnnss")
    candidate = baseName
    index = 0

    Set existingConfiguration = model.GetConfigurationByName(candidate)
    Do While Not existingConfiguration Is Nothing
        index = index + 1
        candidate = baseName & "_" & CStr(index)
        Set existingConfiguration = model.GetConfigurationByName(candidate)
    Loop

    MakeUniqueTemporaryConfigurationName = candidate
End Function

Private Function GetActiveConfigurationName(ByVal model As SldWorks.ModelDoc2) As String
    Dim configuration As SldWorks.Configuration

    On Error GoTo ConfigurationError
    Set configuration = model.GetActiveConfiguration
    If Not configuration Is Nothing Then
        GetActiveConfigurationName = configuration.Name
    Else
        GetActiveConfigurationName = ""
    End If
    Exit Function

ConfigurationError:
    GetActiveConfigurationName = ""
End Function

Private Sub AddReport(ByRef report As String, ByVal lineText As String)
    If Len(report) > 0 Then report = report & vbCrLf
    report = report & lineText
End Sub