Unabhängig machen

Mit diesem Code kann man ein beliebiges Teil in einer Baugruppe über beliebig viele Hierarchien bis zum Root Element unabhängig machen. Dabei wird jede Datei auf dem Weg bis zum Root Element unter einem neuen Namen gespeichert. Spätere Veränderungen und erneutes unabhängig machen erhöht zusätzlich den Index in der Klammer am Ende des Dateinamens. Sollte der Dateiname schon in dem Verzeichnis existieren, wird der Zähler solange hochgezählt, bis die Datei noch nicht existiert.

<pre class="wp-block-syntaxhighlighter-code">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</pre>
Code-Sprache: VB.NET (vbnet)

Schreibe einen Kommentar

Deine E-Mail-Adresse wird nicht veröffentlicht. Erforderliche Felder sind mit * markiert