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. #486
Description
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