У меня часто бывает, что узел смоделирован, а обозначений еще нет или произошла перекомпоновка и надо поменять обозначения. Вот так я это делаю за секунды. Вторая часть тут.
- Макрос применяю в сборке первого уровня, в подсборки не лезу (пока).
- В дереве или в экране сборки выбираем детали (или одну деталь) в порядке, в котором пойдут обозначения.
- В появившемся окне вводим обозначение первой выбранной детали.
- Макрос создает последовательно обозначения, переименовывает детали (файлы деталей) и вносит обозначение и наименование в свойства самой детали (пока не в конфигурации).
- После выполнения макроса сохраняем сборку.
Предупреждение:
Детали в дереве у Solidworks переименовываются временно до сохранения сборки. При сохранении сборки обычно предлагается обновить ссылки на существующие чертежи. Если ссылки не обновить, то в чертежах будут пустые виды т.к. имя файла детали изменено.
Если диалоговое окно не выводится - зайдите в настройки (шестеренку) и нажмите как на картинке.
Как работает макрос:
Выбор, перебор, словарь и коллекция.
Запускается перебор выбранных объектов и идет проверка на компоненты. При выборе деталей мы можем случайно или намеренно выбрать несколько экземпляров одного компонента. Значит остальные экземпляры мы должны выкинуть из списка. Когда мы узнаем имя выбранного компонента, то видим, что у него есть суффикс и функцией базового имени получаем наименование.
Если в словаре такого наименования нет, то оно добавляется в словарь, а деталь добавляется в коллекцию. Применение словаря позволяет добавлять уникальные наименования в качестве ключа без проверки.
Set dict = CreateObject("Scripting.Dictionary")
Set Detali = New Collection
For k = 1 To swSelMgr.GetSelectedObjectCount2(-1)
If swSelMgr.GetSelectedObjectType3(k, -1) = swSelCOMPONENTS Then
Set Detal = swSelMgr.GetSelectedObject6(k, -1)
baseName = ExtractBaseName(Detal.Name2())
If Not dict.Exists(baseName) Then
dict.Add baseName, 0
Detali.Add Detal
End If
End If
Next
Функция Базового имени (ExtractBaseName):
Тут происходит манипуляция со строчными данными. Мы находим последний дефис в названии и выкидываем его и все, что после него.
Function ExtractBaseName(fullName As String) As String
Dim dashPosition As Integer
dashPosition = InStr(StrReverse(fullName), "-")
If dashPosition > 0 Then
ExtractBaseName = Left(fullName, Len(fullName) - dashPosition)
Else
ExtractBaseName = fullName
End If
End Function
Переименовываем детали
Теперь мы перебираем коллекцию с уникальными деталями, создаем обозначение через функцию обозначения. Выбираем и переименовываем детали по одной.
Part.ClearSelection2 (True) 'снимаем выделение с деталей
For k = 1 To Detali.Count
Set Detal = Detali.item(k)
Oboz = CraftOboz(newOboz, k) 'крафтим обозначение
Naim = ExtractBaseName(Detal.Name2()) 'опять достаем наименование
newName = Oboz & " " & Naim
'переименовываем детали
Detal.Select True
longstatus = Part.Extension.RenameDocument(newName)
Part.ClearSelection2 (True)
Next
Функция Обозначения.
В обозначении которое мы ввели, берется цифровая часть после последней точки. К ней прибавляется номер детали из коллекции и учитывается количество знаков для замены их нулями.
Function CraftOboz(newOboz As String, item As Integer) As String
Dim lastDotPosition As Integer
Dim numberPart As String
Dim numberValue As Double
Dim formatString As String
Dim decimalPlaces As Integer
lastDotPosition = InStrRev(newOboz, ".")
If lastDotPosition > 0 Then
numberPart = Mid(newOboz, lastDotPosition + 1)
decimalPlaces = Len(numberPart)
numberValue = CDbl(numberPart) + item - 1
formatString = "." & String(decimalPlaces, "0")
CraftOboz = Left(newOboz, lastDotPosition) & Format(numberValue, String(decimalPlaces, "0"))
Else
CraftOboz = newOboz
End If
End Function
Заполняем свойства детали из сборки:
Как бонус вносим обозначение и наименование детали в свойства детали. Пока не во вкладку конфигурация.
Подробнее о свойствах в следующих постах.
'заполняем свойства деталей
Set swCustPropMgr = Detal.GetModelDoc2.Extension.CustomPropertyManager(Empty)
swCustPropMgr.Add3 "Обозначение", 30, Oboz, 1
swCustPropMgr.Add3 "Наименование", 30, Naim, 1
Код целиком:
Option Explicit
Dim swApp As SldWorks.SldWorks
Dim Part As SldWorks.ModelDoc2
Dim swSelMgr As SldWorks.SelectionMgr
Dim swCustPropMgr As SldWorks.CustomPropertyManager
Dim boolstatus As Boolean
Dim longstatus As Long, longwarnings As Long
Dim newOboz As String
Dim dict As Object
Dim k As Integer
Dim baseName As String
Dim Detal As Variant
Dim Detali As Collection
Dim Oboz, Naim, newName As String
Sub main()
Set swApp = Application.SldWorks
Set Part = swApp.ActiveDoc
Set swSelMgr = Part.SelectionManager
If (swSelMgr.GetSelectedObjectCount2(-1) = 0) Then
MsgBox "Надо выбрать хотя бы одну деталь"
Exit Sub
End If
newOboz = InputBox("Введите обозначение первой детали")
Set dict = CreateObject("Scripting.Dictionary")
Set Detali = New Collection
For k = 1 To swSelMgr.GetSelectedObjectCount2(-1)
If swSelMgr.GetSelectedObjectType3(k, -1) = swSelCOMPONENTS Then
Set Detal = swSelMgr.GetSelectedObject6(k, -1)
baseName = ExtractBaseName(Detal.Name2())
If Not dict.Exists(baseName) Then
dict.Add baseName, 0
Detali.Add Detal
End If
End If
Next
' ' Перебор всех элементов словаря
' Dim key As Variant
' Debug.Print "----- вот что вошло в словарь"
' For Each key In dict.Keys
' Debug.Print key & ": " & dict(key)
' Next key
' Debug.Print "-----"
Part.ClearSelection2 (True) 'снимаем выделение с деталей
For k = 1 To Detali.Count
Set Detal = Detali.item(k)
Oboz = CraftOboz(newOboz, k) 'крафтим обозначение
Naim = ExtractBaseName(Detal.Name2()) 'опять достаем наименование
newName = Oboz & " " & Naim
'заполняем свойства деталей
Set swCustPropMgr = Detal.GetModelDoc2.Extension.CustomPropertyManager(Empty)
swCustPropMgr.Add3 "Обозначение", 30, Oboz, 1
swCustPropMgr.Add3 "Наименование", 30, Naim, 1
'переименовываем детали
Detal.Select True
longstatus = Part.Extension.RenameDocument(newName)
If longstatus = 8 Then
MsgBox "Что-то пошло не так!"
End If
Part.ClearSelection2 (True)
Next
End Sub
Function CraftOboz(newOboz As String, item As Integer) As String
Dim lastDotPosition As Integer
Dim numberPart As String
Dim numberValue As Double
Dim formatString As String
Dim decimalPlaces As Integer
lastDotPosition = InStrRev(newOboz, ".")
If lastDotPosition > 0 Then
numberPart = Mid(newOboz, lastDotPosition + 1)
decimalPlaces = Len(numberPart)
numberValue = CDbl(numberPart) + item - 1
formatString = "." & String(decimalPlaces, "0")
CraftOboz = Left(newOboz, lastDotPosition) & Format(numberValue, String(decimalPlaces, "0"))
Else
CraftOboz = newOboz
End If
End Function
Function ExtractBaseName(fullName As String) As String
Dim dashPosition As Integer
dashPosition = InStr(StrReverse(fullName), "-")
If dashPosition > 0 Then
ExtractBaseName = Left(fullName, Len(fullName) - dashPosition)
Else
ExtractBaseName = fullName
End If
End Function
Заключение.
Запускаем сортировщик и вообще красота. Cортировщик я нашел на просторах сети.
Макрос будет дорабатываться в следующих постах. Как минимум чтобы он сначала убирал обозначения. Продолжение тут.
Напишите в комментариях интересующие темы и вопросы— разберём их в следующих постах.
#SolidWorks #VBA #Макросы #Автоматизация #Инженерия #Конструирование