Сквозная нумерация Деталей, Конфигураций в текущей сборки. Solidworks 2024.

[a5lex91 0]

Сквозная нумерация выполнятся через код VBA. 

Детали добавляется новое свойство "Номер детали" с номером, в конфигурацию добавляется новое свойство "НомКонфиг".

Если в детали имеется одна конфигурация то присваивается "Номер детали".

Если в детали имеется множество конфигураций, в каждую конфигурацию добавляется свойство "НомКонфиг" присваивается "Номер детали"-"Порядковый номер конфигурации."

Пример одна конфиг.

"Номер детали"-1.

"НомКонфиг"-1

Пример несколько конфиг.

"Номер детали"

1. конфиг "НомКонфиг"- 1-1

2. конфиг "НомКонфиг"- 1-2

N. конфиг "НомКонфиг"- 1-N

Сам Код VBA

Option Explicit

Sub НумерацияДетелейИКонфигураций()
    Dim swApp As SldWorks.SldWorks
    Dim swModel As SldWorks.ModelDoc2
    Dim swAssy As SldWorks.AssemblyDoc
    Dim swComp As SldWorks.Component2
    Dim vComps As Variant
    Dim i As Long, j As Long
    Dim dictKeys As Object  ' Словарь для уникальных деталей
    Dim nextNum As Long
    Dim configName As String
    Dim configNames As Variant
    Dim prop As SldWorks.CustomPropertyManager
    Dim compModel As SldWorks.ModelDoc2
    Dim propValue As String
    Dim addResult As Boolean
    Dim debugMsg As String  ' Для отладки
    debugMsg = "Отладка:" & vbCrLf

    On Error GoTo ErrorHandler
    Set swApp = Application.SldWorks
    Set swModel = swApp.ActiveDoc

    ' 1. Проверка: открыт ли документ
    If swModel Is Nothing Then
        MsgBox "Нет открытой модели!", vbExclamation
        Exit Sub
    End If

    ' 2. Проверка: это сборка?
    If swModel.GetType <> swDocumentTypes_e.swDocASSEMBLY Then
        MsgBox "Откройте сборку!", vbExclamation
        Exit Sub
    End If

    Set swAssy = swModel
    vComps = swAssy.GetComponents(False)

    If IsEmpty(vComps) Then
        MsgBox "Сборка пуста!", vbInformation
        Exit Sub
    End If

    ' 3. Инициализация словаря для уникальных деталей
    Set dictKeys = CreateObject("Scripting.Dictionary")
    nextNum = 1

    ' 4. Цикл по компонентам сборки
    For i = 0 To UBound(vComps)
        Set swComp = vComps(i)
        Dim partPath As String: partPath = swComp.GetPathName

        ' Пропускаем виртуальные компоненты и подсборки
        If partPath = "" Or InStr(partPath, ".sldasm") > 0 Then GoTo NextComponent

        Dim partName As String: partName = Mid(partPath, InStrRev(partPath, "\") + 1)
        Dim key As String: key = partPath & "|" & partName

        ' 5. Присваиваем уникальный номер детали
        If Not dictKeys.Exists(key) Then
            dictKeys(key) = nextNum
            nextNum = nextNum + 1
        End If
        Dim nDetail As Long: nDetail = dictKeys(key)

        Set compModel = swComp.GetModelDoc2

        If compModel Is Nothing Then GoTo NextComponent

        debugMsg = debugMsg & "Компонент: " & swComp.Name2 & vbCrLf
        debugMsg = debugMsg & "  Уникальный номер: " & nDetail & vbCrLf

        ' 6. Работа с корневым свойством (без конфигурации)
        Set prop = swComp.CustomPropertyManager("")

        ' Проверяем, есть ли уже "Номер детали"
        propValue = ""
        On Error Resume Next
        propValue = prop.GetSpecifiedValue2("Номер детали", "")
        If Err.Number <> 0 Then
            Err.Clear
            propValue = ""
        End If
        On Error GoTo ErrorHandler

        debugMsg = debugMsg & "  Исходный 'Номер детали': " & propValue & vbCrLf

        ' Если свойства нет — записываем новый номер
        If propValue = "" Or propValue = "Null" Then
            On Error Resume Next
            addResult = prop.Add3( _
                "Номер детали", _
                swCustomInfoType_e.swCustomInfoText, _
                CStr(nDetail), _
                swCustomPropertyAddOption_e.swCustomPropertyReplaceValue _
            )
            If Err.Number <> 0 Or Not addResult Then
                Err.Clear
                debugMsg = debugMsg & "  Ошибка записи 'Номер детали'!" & vbCrLf
            Else
                debugMsg = debugMsg & "  Записан 'Номер детали': " & nDetail & vbCrLf
            End If
            On Error GoTo ErrorHandler
        Else
            debugMsg = debugMsg & "  'Номер детали' уже есть, не перезаписываем: " & propValue & vbCrLf
        End If

        ' 7. Работа с конфигурациями
        configNames = compModel.GetConfigurationNames
        debugMsg = debugMsg & "  Конфигурации: " & IIf(IsEmpty(configNames), 0, UBound(configNames) + 1) & vbCrLf

        If Not IsEmpty(configNames) Then
            If UBound(configNames) > 0 Then
                ' Несколько конфигураций: N-1, N-2, ...
                For j = 0 To UBound(configNames)
                    configName = configNames(j)
                    Set prop = swComp.CustomPropertyManager(configName)

                    On Error Resume Next
                    addResult = prop.Add3( _
                        "НомКонфиг", _
                        swCustomInfoType_e.swCustomInfoText, _
                        CStr(nDetail) & "-" & CStr(j + 1), _
                        swCustomPropertyAddOption_e.swCustomPropertyReplaceValue _
                    )
                    If Err.Number <> 0 Or Not addResult Then
                        Err.Clear
                        debugMsg = debugMsg & "  Ошибка в конфигурации '" & configName & "': не записан 'НомКонфиг'" & vbCrLf
                    Else
                        debugMsg = debugMsg & "  Записан 'НомКонфиг' в '" & configName & "': " & nDetail & "-" & (j + 1) & vbCrLf
                    End If
                    On Error GoTo ErrorHandler
                Next j
            Else
                ' Одна конфигурация: N
                configName = configNames(0)
                Set prop = swComp.CustomPropertyManager(configName)

                On Error Resume Next
                addResult = prop.Add3( _
                    "НомКонфиг", _
                    swCustomInfoType_e.swCustomInfoText, _
                    CStr(nDetail), _
                    swCustomPropertyAddOption_e.swCustomPropertyReplaceValue _
                )
                If Err.Number <> 0 Or Not addResult Then
                    Err.Clear
                    debugMsg = debugMsg & "  Ошибка в конфигурации '" & configName & "': не записан 'НомКонфиг'" & vbCrLf
                Else
                    debugMsg = debugMsg & "  Записан 'НомКонфиг' в '" & configName & "': " & nDetail & vbCrLf
                End If
                On Error GoTo ErrorHandler
            End If
        Else
            ' Нет конфигураций: записываем N-1
            Set prop = swComp.CustomPropertyManager("")
            On Error Resume Next
            addResult = prop.Add3( _
                "НомКонфиг", _
                swCustomInfoType_e.swCustomInfoText, _
                CStr(nDetail) & "-1", _
                swCustomPropertyAddOption_e.swCustomPropertyReplaceValue _
            )
            If Err.Number <> 0 Or Not addResult Then
                Err.Clear
                debugMsg = debugMsg & "  Ошибка: не записан 'НомКонфиг' (N-1)" & vbCrLf
            Else
                debugMsg = debugMsg & "  Записан 'НомКонфиг' (N-1): " & nDetail & "-1" & vbCrLf
            End If
            On Error GoTo ErrorHandler
        End If
NextComponent:
    Next i

    ' 8. Вывод результата
    debugMsg = debugMsg & vbCrLf & "Нумерация завершена! Всего уникальных деталей: " & (nextNum - 1)
    MsgBox debugMsg, vbInformation, "Результат выполнения"
    Exit Sub

ErrorHandler:
    MsgBox "Ошибка: " & Err.Description & vbCrLf & _
           "Строка: " & Erl, vbCritical, "Ошибка выполнения макроса"
End Sub

 

[a5lex91 0]

Код Для удаления всех нумераций из деталей.

Option Explicit

Sub УдалитьСвойстваДеталиИКонфигураций()
    Dim swApp As SldWorks.SldWorks
    Dim swModel As ModelDoc2
    Dim swAssy As AssemblyDoc
    Dim swComp As Component2
    Dim vComps As Variant
    Dim i As Long, j As Long
    Dim configName As String
    Dim configNames As Variant
    Dim prop As CustomPropertyManager
    Dim compModel As ModelDoc2
    Dim propsToDelete As Variant
    Dim propName As Variant
    
    ' Список удаляемых свойств
    propsToDelete = Array("Номер детали", "НомКонфиг")
    
    ' Подключение к SolidWorks
    Set swApp = Application.SldWorks
    Set swModel = swApp.ActiveDoc
    
    If swModel Is Nothing Then
        MsgBox "Нет открытой модели!", vbExclamation
        Exit Sub
    End If
    
    If swModel.GetType <> swDocumentTypes_e.swDocASSEMBLY Then
        MsgBox "Откройте сборку!", vbExclamation
        Exit Sub
    End If
    
    Set swAssy = swModel
    
    ' Получаем все компоненты сборки
    vComps = swAssy.GetComponents(False)
    If IsEmpty(vComps) Then
        MsgBox "Сборка пуста!", vbInformation
        Exit Sub
    End If
    
    ' Проходим по всем компонентам
    For i = 0 To UBound(vComps)
        Set swComp = vComps(i)
        
        ' Только детали (не субсборки)
        If swComp.GetPathName <> "" And InStr(swComp.GetPathName, ".sldasm") = 0 Then
            
            ' Получаем модель компонента (деталь)
            Set compModel = swComp.GetModelDoc2
            If compModel Is Nothing Then
                MsgBox "Не удалось получить модель компонента: " & swComp.Name2, vbExclamation
                GoTo NextComponent
            End If
            
            ' Менеджер свойств для основной конфигурации компонента
            Set prop = swComp.CustomPropertyManager("")
            
            ' Удаляем свойства из основной конфигурации
            For Each propName In propsToDelete
                If prop.Get(propName) <> "" Then
                    prop.Delete propName
                End If
            Next propName
            
            ' Получаем список конфигураций детали
            configNames = compModel.GetConfigurationNames
            If Not IsEmpty(configNames) Then
                For j = 0 To UBound(configNames)
                    configName = configNames(j)
                    
                    ' Менеджер свойств для конкретной конфигурации
                    Set prop = swComp.CustomPropertyManager(configName)
                    
                    ' Удаляем свойства из каждой конфигурации
                    For Each propName In propsToDelete
                        If prop.Get(propName) <> "" Then
                            prop.Delete propName
                        End If
                    Next propName
                Next j
            Else
                ' Если конфигураций нет — удаляем из пустой конфигурации
                Set prop = swComp.CustomPropertyManager("")
                For Each propName In propsToDelete
                    If prop.Get(propName) <> "" Then
                        prop.Delete propName
                    End If
                Next propName
            End If
        End If
NextComponent:
    Next i
    
    MsgBox "Удаление свойств завершено!", vbInformation
End Sub

[a5lex91 0]

Набор макросов. Сквозной нумерации деталей в одной сборки.

Вариантов несколько.

1) Занесения номера детали в Главное свойство детали. (Имя свойства "Номер детали")

2) Занесение номера как в главное свойство детали так и нумерация конфигураций в самой детали с занесением в свойство каждой конфигурации. (Имя свойства "НомКофиг")

3) Удаление свойств "Номер детали" и "НомКофиг".

4) В открытой Сборки ПЕРЕИМЕНОВАНИЕ  Имени детали по шаблону пользователя (Суффикс- номер детали)  в дереве конструирования. С обновлением и сохранение всех ссылок.

https://disk.yandex.ru/d/PxXf7ccE3qdBjw

 

Сильно не кидаться камнями. Только в процессе осваивания программирования.

Возможно необходимом будет установить Solidworks API.

Работоспособность проверена Solidworks 2024 SP5.

[Kelny 1,516]

48 минут назад, a5lex91 сказал:

Набор макросов.

Думается, хорошим тоном было бы в архив с программой класть файл с описанием программы и возможно скриншотами, что бы понимать, что это за програмка и что делает.

 

49 минут назад, a5lex91 сказал:

https://disk.yandex.ru/d/PxXf7ccE3qdBjw

После 5-10 сообщений можно приложить архив прямо к сообщению, что бы со временем архив не потерялся на стороннем ресурсе.

[a5lex91 0]

1 час назад, Kelny сказал:

Думается, хорошим тоном было бы в архив с программой класть файл с описанием программы и возможно скриншотами, что бы понимать, что это за програмка и что делает.

 

После 5-10 сообщений можно приложить архив прямо к сообщению, что бы со временем архив не потерялся на стороннем ресурсе.

В процессе, обновления будут прилагаться. Есть еще над чем поработать. Весь интернет прошарил, в поисках макроса переименовании деталей в сборке. Так как надоело именовать их вручную. Люди которые заморачивались по этому поводу меня поймут.

[malvi.dp 301]

13 часов назад, a5lex91 сказал:

Весь интернет прошарил, в поисках макроса переименовании деталей в сборке.

В соседней теме поищите макрос ПеКо или SaveAsCopy...

[a5lex91 0]

23 минуты назад, malvi.dp сказал:

В соседней теме поищите макрос ПеКо или SaveAsCopy...

Спасибо. Этот метод похож Pack and Go.

Суть идеи заключается в следующем.

Имеется Главная сборка с кучей под сборок и кучей деталей. Все Детали необходимо переименовать по одному шаблону и пронумеровать, А все остальные сборки по другому шаблону и тоже пронумеровать.

[a5lex91 0]

Набор макросов сквозной нумерации, переименование деталей и сборок.

Варианты использование:

1. Единый макрос под названием ПРИЛОЖЕНИЕ.SWP - включены все макросы нумерации и переименования сборок и деталей. С возможностью запускать совместную нумерацию, переименование, удаление. Так же и по раздельности.

2. Макросы разделены. В имени макроса можно понять какие действия выполняет.

Номера присваиваются в деталь и сборку, записываются в свойство.  ("НомерДТ", "НомерСБ")

Выполняет запрос пользователя шаблонов имен деталей и сборок. Номер будет как суффикс. 

В свойство главной сборки добавляются новые свойства для дальнейшей нумерации.

При удалении любой нумерации эти свойства удаляются. 

"СчётчикСБ"

"СчётчикДТ"

 

Ссылки везде обновляются автоматически.

Проверено Solidworks 2024 SP5

 

Есть шанс работы и в старых версиях. Не проверял.

Версия 1.0.rar

Переименование происходит при авто открытие каждой сборки.

Номера заносятся без открытий сборок.