Это продолжение статьи про переименование нескольких деталей из дерева. Начало тут. Повторюсь, что я выкладываю всего лишь один из вариантов кода решения. Весь смысл постов больше в том, чтобы показать как из кусков кода из хелпа или от нейросети подходить к алгоритму и синтезировать решение.
Как работает макрос:
Выбираем детали (одну или несколько, можно с повторениями) в дереве или поле модели. Запускаем макрос. Формируется список деталей с уникальными названиями. Из названия берется первое слово и проверяется на наличие цифр. Если цифры есть, то это слово убирается. Если цифр нет - остается. Если оставшееся наименование детали повторяется, то мы добавляем в конце наименования дополнительную цифру.
Первая часть идентична коду из прошлой статьи. Проходим по выбранным деталям, узнаем имя детали без суффиксов, составляем список уникальных деталей.
Option Explicit
Dim swApp As SldWorks.SldWorks
Dim Part As SldWorks.ModelDoc2
Dim swSelMgr As SldWorks.SelectionMgr
Dim longstatus As Long, longwarnings As Long
Dim dict As Object
Dim k, i As Integer
Dim baseName As String
Dim Detal As Variant
Dim Detali As Collection
Dim Naim 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
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
Part.ClearSelection2 (True)
Во второй части разбиваем имя на слова, в первом слове ищем цифры и отбрасываем его. Пробуем переименовать деталь.
Код целиком:
Option Explicit
Dim swApp As SldWorks.SldWorks
Dim Part As SldWorks.ModelDoc2
Dim swSelMgr As SldWorks.SelectionMgr
Dim longstatus As Long, longwarnings As Long
Dim dict As Object
Dim k, i As Integer
Dim baseName As String
Dim Detal As Variant
Dim Detali As Collection
Dim Naim 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
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
Part.ClearSelection2 (True)
i = 1
For k = 1 To Detali.Count
Set Detal = Detali.Item(k)
Naim = ExtractBaseName(Detal.Name2()) 'опять достаем наименование
Dim Slova As Variant
Slova = Split(Naim, " ")
'Строка сравнения на наличие цифр в первом слове
If Slova(0) Like "*#*" And InStr(1, Naim, " ") <> 0 Then
Naim = Right(Naim, Len(Naim) - Len(Slova(0)) - 1)
End If
'переименовываем детали
Detal.Select True
longstatus = Part.Extension.RenameDocument(Naim)
'проверка на возможность назвать деталь именем Naim
If longstatus = 12 Or longstatus = 8 Then
Naim = Naim & " " & i
longstatus = Part.Extension.RenameDocument(Naim)
i = i + 1
End If
Part.ClearSelection2 (True)
Next
End Sub
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
Заключение.
Можно, конечно, объединить оба макроса в один. Но я не хотел усложнять. Не всегда мне нужно сразу задавать новое обозначение.
Напишите в комментариях интересующие темы и вопросы— разберём их в следующих постах.
#SolidWorks #VBA #Макросы #Автоматизация #Инженерия #Конструирование