xarial
macro to rename all components in assembly using "jn" custom property from main assembly file. Works in solidworks 2024. I need it to work in 2025.
Option Explicit
#If VBA7 Then Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long Private Declare PtrSafe Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As LongPtr) As LongPtr Private Declare PtrSafe Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As LongPtr) As LongPtr Private Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr Private Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongPtr) As Long Private Declare PtrSafe Function lstrcpy Lib "kernel32" (ByVal lpString1 As LongPtr, ByVal lpString2 As String) As LongPtr #Else Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long Private Declare Function EmptyClipboard Lib "user32" () As Long Private Declare Function CloseClipboard Lib "user32" () As Long Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long Private Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As LongPtr, ByVal lpString2 As String) As Long #End If
Private Const CF_TEXT As Long = 1 Private Const GMEM_MOVEABLE As Long = &H2
'--------------------------------------------- ' Helper: copy text to clipboard via API '--------------------------------------------- Sub CopyToClipboardAPI(sText As String) Dim hGlobal As LongPtr Dim lpGlobal As LongPtr If OpenClipboard(0) Then EmptyClipboard hGlobal = GlobalAlloc(GMEM_MOVEABLE, Len(sText) + 1) lpGlobal = GlobalLock(hGlobal) lstrcpy lpGlobal, sText GlobalUnlock hGlobal SetClipboardData CF_TEXT, hGlobal CloseClipboard End If End Sub
'--------------------------------------------- ' Main macro: rename components with Add/Remove description '--------------------------------------------- Sub RenameComponentsWithJN_Full_AddRemove() Dim swApp As SldWorks.SldWorks Dim swModel As SldWorks.ModelDoc2 Dim swSelMgr As SldWorks.SelectionMgr Dim swComp As SldWorks.Component2 Dim swChild As SldWorks.ModelDoc2 Dim swExt As SldWorks.ModelDocExtension Dim swCust As SldWorks.CustomPropertyManager
Dim selCount As Long, i As Long
Dim oldName As String, newName As String
Dim oldFilePath As String, newFilePath As String
Dim folder As String, ext As String
Dim jn As String, description As String
Dim prefix As String
Dim suffixPos As Long
Dim errors As Long, warnings As Long
Dim fso As Object
Dim action As String
Dim baseName As String, suffix As String
Dim numPart As Integer
' --- Get SW application & model ---
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
If swModel Is Nothing Then MsgBox "Open an assembly first.": Exit Sub
' --- Read JN from assembly ---
Set swCust = swModel.Extension.CustomPropertyManager("")
swCust.Get4 "jn", False, "", jn
If Trim(jn) = "" Then MsgBox "Assembly JN missing.": Exit Sub
' --- Ask user if they want to Add or Remove description ---
action = InputBox("Type 'A' to Add description or 'R' to Remove description:", "Action Choice", "A")
action = UCase(Trim(action))
If action <> "A" And action <> "R" Then MsgBox "Invalid input.": Exit Sub
' --- Optional prefix ---
prefix = ""
Dim userInput As String
userInput = InputBox("Enter component location prefix: T for Top, B for Bottom, leave blank for none:", "Prefix Option")
userInput = UCase(Trim(userInput))
If userInput = "T" Then prefix = "Top_"
If userInput = "B" Then prefix = "Bot_"
' --- Optional description (only if adding) ---
If action = "A" Then
description = InputBox("Enter description to append (leave blank for none):", "Optional Description")
description = Trim(description)
If description <> "" Then description = "_" & description
If description <> "" Then
CopyToClipboardAPI (description)
MsgBox "Description '" & description & "' copied to clipboard."
End If
End If
' --- Get selection manager ---
Set swSelMgr = swModel.SelectionManager
selCount = swSelMgr.GetSelectedObjectCount2(-1)
If selCount < 1 Then MsgBox "Select components first.": Exit Sub
Set fso = CreateObject("Scripting.FileSystemObject")
' --- Loop through selected components ---
For i = 1 To selCount
If swSelMgr.GetSelectedObjectType3(i, -1) = swSelCOMPONENTS Then
Set swComp = swSelMgr.GetSelectedObjectsComponent4(i, -1)
If swComp Is Nothing Then GoTo NextComp
Set swChild = swComp.GetModelDoc2()
If swChild Is Nothing Then GoTo NextComp
Set swExt = swChild.Extension
oldName = swComp.Name2
' --- Preserve numeric suffix if exists ---
suffixPos = InStrRev(oldName, "-")
If suffixPos > 0 Then
baseName = Left(oldName, suffixPos - 1)
suffix = Mid(oldName, suffixPos)
Else
baseName = oldName
suffix = ""
End If
' --- Determine new name based on Add or Remove ---
If action = "A" Then
newName = prefix & jn & description & suffix
ElseIf action = "R" Then
' Remove description by deleting anything after JN but before numeric suffix
newName = prefix & jn & suffix
End If
' --- Rename component instance ---
swComp.Name2 = newName
' --- Rename file on disk ---
oldFilePath = swChild.GetPathName()
folder = Left(oldFilePath, InStrRev(oldFilePath, "\"))
ext = Mid(oldFilePath, InStrRev(oldFilePath, "."))
If ext = "" Then ext = ".SLDPRT"
newFilePath = folder & newName & ext
' Avoid overwriting
Do While fso.FileExists(newFilePath)
If suffixPos > 0 Then
numPart = CInt(Mid(suffix, 2)) + 1
suffix = "-" & Format(numPart, "00")
Else
suffix = "-01"
End If
If action = "A" Then
newName = prefix & jn & description & suffix
Else
newName = prefix & jn & suffix
End If
swComp.Name2 = newName
newFilePath = folder & newName & ext
Loop
swExt.SaveAs newFilePath, 0, 0, Nothing, errors, warnings
NextComp: End If Next
MsgBox "Components renamed successfully with JN, optional prefix, and description handling."
End Sub
