Unabhängig machen

Option Explicit
Sub main()
    Dim swApp As SldWorks.SldWorks
    Set swApp = Application.SldWorks
    
    Dim swModel As ModelDoc2
    Set swModel = swApp.ActiveDoc
    
    If swModel Is Nothing Then
        swApp.SendMsgToUser "Kein Dokument geladen!"
        Exit Sub
    End If
    
    If Not swModel.GetType = swDocASSEMBLY Then
        swApp.SendMsgToUser "Keine Baugruppe aktiv!"
        Exit Sub
    End If
    
    Dim swSelMgr As SelectionMgr
    Set swSelMgr = swModel.SelectionManager
    If swSelMgr.GetSelectedObjectCount2(-1) < 1 Then
        swApp.SendMsgToUser2 "Keine Auswahl getroffen.", swMessageBoxIcon_e.swMbStop, swMessageBoxBtn_e.swMbOk
        Exit Sub
    End If
 
    Dim swSelectType As swSelectType_e
    swSelectType = swSelMgr.GetSelectedObjectType3(1, -1)
    
    Dim swSelObj As Variant
    Dim swSelComp As Component2
    Select Case swSelectType
        Case swSelectType_e.swSelFACES
            Set swSelObj = swSelMgr.GetSelectedObjectsComponent4(1, -1)
            Set swSelComp = swSelObj
        Case swSelectType_e.swSelEDGES
            Set swSelObj = swSelMgr.GetSelectedObjectsComponent4(1, -1)
            Set swSelComp = swSelObj
        Case swSelectType_e.swSelVERTICES
            Set swSelObj = swSelMgr.GetSelectedObjectsComponent4(1, -1)
            Set swSelComp = swSelObj
        Case swSelectType_e.swSelCOMPONENTS
            Set swSelObj = swSelMgr.GetSelectedObject6(1, -1)
            Set swSelComp = swSelObj
        Case Else
            swApp.SendMsgToUser2 "Keine unterstützte Auswahl getroffen.", _
                                swMessageBoxIcon_e.swMbInformation, _
                                swMessageBoxBtn_e.swMbOk
            Exit Sub
    End Select
    
    Dim swAssembly As AssemblyDoc
    Set swAssembly = swModel
    
    Dim CompArr As Variant
    CompArr = swAssembly.GetComponents(False)
    
    Dim comp As Variant
    Dim swComp As Component2
    Dim swCompTrace As New Collection
    For Each comp In CompArr
        Set swComp = comp
        If swComp Is swSelComp Then
            swCompTrace.Add swComp
            Do
                Set swComp = swComp.GetParent
                If swComp Is Nothing Then Exit Do
                swCompTrace.Add swComp
            Loop
            Exit For
        End If
    Next
    
    Dim Path As String
    Path = swModel.GetPathName
    
    Dim version As String
    Path = GetNewVersionComplete(Path)
    Dim Errors As Long
    Dim Warnings As Long
    swModel.Extension.SaveAs2 Path, swSaveAsVersion_e.swSaveAsCurrentVersion, swSaveAsOptions_e.swSaveAsOptions_Silent, Nothing, "", False, Errors, Warnings
    
    Dim num As Integer
    Dim swSelModelDoc As ModelDoc2
    For num = swCompTrace.Count To 1 Step -1
        swCompTrace.Item(num).Select4 False, Nothing, False
        Set swSelModelDoc = swCompTrace.Item(num).GetModelDoc2
        Path = swSelModelDoc.GetPathName
        Path = GetNewVersionComplete(Path)
        swAssembly.MakeIndependent Path
    Next
End Sub
Private Function GetNewVersionComplete(ByVal name As String) As String
    Dim leftPart As String
    Dim rightPart As String
    Dim version As Integer
    
    Dim CounterSize As Integer
    CounterSize = 4 'Die Anzahl der Ziffern in der Klammer
    
    Dim ExtensionSize As Integer
    ExtensionSize = 7 'Dateierweiterung und Punkt z.B.: .sldprt
    
    If Mid(name, Len(name) - ExtensionSize, 1) = ")" Then
        leftPart = Left(name, Len(name) - ExtensionSize - CounterSize - 2)
        
        rightPart = Right(name, ExtensionSize)
        
        Dim middlePart As String
        middlePart = Mid(name, Len(name) - ExtensionSize - CounterSize - 1, CounterSize + 2) 'z.B.: (0000)
        
        If Left(middlePart, 1) = "(" And Right(middlePart, 1) = ")" Then
            If IsNumeric(Mid(middlePart, 2, CounterSize)) Then 'Anfangen nach der ( und die Anzahl der Ziffern
                version = CInt(Mid(middlePart, 2, CounterSize)) + 1 'Die Ziffern in einen Integer konvertieren und um Eins erhöhen
            End If
        End If
    Else
        leftPart = Left(name, Len(name) - ExtensionSize)
        rightPart = Right(name, ExtensionSize)
    End If
    
    Dim NewFileExists As Boolean
    Dim NewPathFileName As String
    Do
        NewFileExists = False
        'ausgehend von der Ziffernmenge Vier
        Select Case True
            Case version = 0
                If FileExists(leftPart & "(0001)" & rightPart) Then
                    NewFileExists = True
                Else
                    NewPathFileName = leftPart & "(0001)" & rightPart
                End If
            Case version >= 1 And version < 10
                If FileExists(leftPart & "(000" & version & ")" & rightPart) Then
                    NewFileExists = True
                Else
                    NewPathFileName = leftPart & "(000" & version & ")" & rightPart
                End If
            Case version >= 10 And version < 100
                If FileExists(leftPart & "(00" & version & ")" & rightPart) Then
                    NewFileExists = True
                Else
                    NewPathFileName = leftPart & "(00" & version & ")" & rightPart
                End If
            Case version >= 100 And version < 1000
                If FileExists(leftPart & "(0" & version & ")" & rightPart) Then
                    NewFileExists = True
                Else
                    NewPathFileName = leftPart & "(0" & version & ")" & rightPart
                End If
            Case version >= 1000 And version < 10000
                If FileExists(leftPart & "(" & version & ")" & rightPart) Then
                    NewFileExists = True
                Else
                    NewPathFileName = leftPart & "(" & version & ")" & rightPart
                End If
        End Select
        version = version + 1
    Loop While NewFileExists = True
    
    GetNewVersionComplete = NewPathFileName
End Function
Private Function FileExists(FilePath As String) As Boolean
    Dim TestStr As String
    TestStr = ""
    On Error Resume Next
    TestStr = Dir(FilePath)
    On Error GoTo 0
    If TestStr = "" Then
        FileExists = False
    Else
        FileExists = True
    End If
End Function