I just searched for removing copy of from Virtual Components and in just a couple of minutes I had found the post, downloaded the graciously shared macro and tested it. I thought to my self, in a month that will not be a possibility any longer. All of those shared macros, gone. So this one is not mine but it just helped me out.
posted by Koos Kubus
Code: Select all
Option Explicit
Dim swApp As SldWorks.SldWorks
Sub main()
Dim swModel As ModelDoc2
Dim swRootComp As SldWorks.Component2
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
'check if an assembly is open
If swModel Is Nothing Then Exit Sub
If Not swModel.GetType = swDocASSEMBLY Then Exit Sub
'get root component for this assembly (configuration)
Set swRootComp = swModel.ConfigurationManager.ActiveConfiguration.GetRootComponent3(True)
TraverseAssembly swRootComp
End Sub
' Traverse an assembly, to find all child-components
Sub TraverseAssembly(swComp As Component2)
Dim swChildComp As SldWorks.Component2
Dim vChild As Variant
Dim ComponentsAtSameLevel As Collection
Set ComponentsAtSameLevel = New Collection
'try to loop through children of this component
For Each vChild In swComp.GetChildren
Set swChildComp = vChild
'only change virtual components
If swChildComp.IsVirtual Then
'use this procedure as recursive procedure, to go one level deeper
TraverseAssembly swChildComp
ComponentsAtSameLevel.Add swChildComp
End If
Next vChild
RenameComponentsCollection ComponentsAtSameLevel
End Sub
'Rename all components in a collection
Sub RenameComponentsCollection(Components As Collection)
Const Find1 As String = "Copy of "
Const Find2 As String = ") of "
Dim swComponent As Component2
Dim NewName As String
For Each swComponent In Components
NewName = GetCompName(swComponent)
RemoveLeftOfString NewName, Find1
RemoveLeftOfString NewName, Find2
RenameComponent swComponent, NewName
Next swComponent
End Sub
' Remove SubString (and all characters to the left of it) from the MainString
Sub RemoveLeftOfString(ByRef MainString As String, SubString As String)
If InStrRev(MainString, SubString) <> 0 Then
MainString = Right(MainString, Len(MainString) - InStrRev(MainString, SubString) - Len(SubString) + 1)
End If
End Sub
' Rename a Component and add an iterator if the new Component-name is not available
Sub RenameComponent(swComponent As Component2, NewName As String, Optional Iteration As Long)
Dim NewNameWithIterator As String
NewNameWithIterator = NewName
If Iteration > 0 Then NewNameWithIterator = NewName & " " & Iteration
swComponent.Select4 False, Nothing, False
swComponent.Name2 = NewNameWithIterator
If GetCompName(swComponent) <> NewNameWithIterator And Iteration < 10 Then
RenameComponent swComponent, NewName, Iteration + 1
End If
End Sub
' Get the short name of the Component
Function GetCompName(swComp As Component2) As String
Dim compname As String
compname = swComp.Name2
compname = Right(compname, Len(compname) - InStrRev(compname, "/"))
compname = Left(compname, InStr(compname, "^") - 1)
GetCompName = compname
End Function 
