CAD Forum

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