---

Hallo Leute,
ich wünsche allen ein gesundes Neues Jahr.

Nun zu meiner Frage.
Ich habe per VBA Baugruppen mit ihrer Datenstruktur (Unterverzeichnisse) auf einen bestimmten Pfad außerhalb des Projektarbeitsbereiches (ähnlich wie Packngo) erstellt/kopiert.
Dort werden bei diesem Vorgang aber automatisch auch schon OldVersions angelegt. Diese möchte ich im letzten Schritt löschen.

Gibt es eine Möglichkeit, unter Kenntnis des neuen Wurzelpfades, alle OldVersions zu löschen?
Bei KILL und RMDIR sollte es eigentlich möglich sein, Platzhalter zu verwenden, aber ich habe es nicht hinbekommen.

Code:

---

Kill sWurzelpfad & "*OldVersions*"
RmDir sWurzelpfad & "*OldVersions"

---

.

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hallo

Du musst, ausgehend vom Wurzelverzeichnis, rekursiv durch durch alle Unterverzeichnisse laufen. Wenn OldVersions, dann alle Dateien löschen, anschließend das Verzeichnis selbst. Es lassen sich nur leere Verzeichnisse löschen. Mit den Platzhaltern hat das nichts zu tun. Das Beispiel unten geht davon aus, dass in OldVersions KEINE Unterverzeichnisse existieren. Die eigentlichen Löschbefehle sind kommentiert, damit man erstmal einen Trockenlauf machen und das Ergebnis kontrollieren kann.

Wäre es alternativ möglich eine Projektdatei ohne OldVersions (Option "beizubehaltende alte Versionen" = 0) vor dem Export zu aktivieren?

Code:

---

Private Sub KillOldVersions()
    Dim sRootFolder As String
    sRootFolder = "" ' <------------- Wurzelpfad eintragen
   
    Dim sSearchFolder As String
    sSearchFolder = "OldVersions"
   
    Dim oFSO As FileSystemObject
    Set oFSO = CreateObject("Scripting.FileSystemObject")
   
    Dim oFolder As Folder
    Set oFolder = oFSO.GetFolder(sRootFolder)
   
    TraverseFolder oFSO, oFolder, sSearchFolder
End Sub

Private Sub TraverseFolder(ByRef oFSO As FileSystemObject, ByVal oFolder As Folder, ByVal sSearchFolder As String)

    Dim sFolder As String
    sFolder = oFolder.Path

    'Durchlauf aller Unterverzeichnisse
    Dim oSubFolder As Folder
    For Each oSubFolder In oFolder.SubFolders
        TraverseFolder oSubFolder, sSearchFolder
    Next
   
    If oFolder.Name = sSearchFolder Then
        'Alle Dateien im Ordner löschen
        Dim oFile As Object
        For Each oFile In oFolder.Files
            Debug.Print oFile.Path
            'oFSO.DeleteFile oFile.Path, True '<------------- aktivieren, wenn Test erfolgreich
        Next
       
        'OldVersions Verzeichnis löschen
        'If oFolder.Files.Count = 0 And oFolder.SubFolders.Count = 0 Then  '<------------- aktivieren, wenn Test erfolgreich
            Debug.Print oFolder.Path
        '    oFolder.Delete vbTrue '<------------- aktivieren, wenn Test erfolgreich
        'End If '<------------- aktivieren, wenn Test erfolgreich
    End If
   
End Sub

---

------------------
MfG
Ralf

RKW Solutions GmbH
www.RKW-Solutions.com

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Danke erst mal für die Antwort. Ich werde das bei nächster Gelegenheit probieren.

Natürlich könnte ich in der Projektdatei den Wert für OldVersions auf 0 setzen. Aber mir hat das hin und wieder schon den A*** gerettet. Bei mir steht der Wert sogar auf 3.

.

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Code:

---

Private Sub TraverseFolder(ByRef oFSO As FileSystemObject, ByVal oFolder As Folder, ByVal sSearchFolder As String)

---

Hier bekomme ich eine Fehlermeldung beim Complieren.
Compile error:
User-defined type not defined

Habe ich irgend etwas übersehen?

.

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hallo

Im VBA-Editor unter "Extras" --> "Verweise" nach "Microsoft Scripting Runtime" suchen und aktivieren.

------------------
MfG
Ralf

RKW Solutions GmbH
www.RKW-Solutions.com

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

So, ich habe endlich Zeit gefunden, das Thema zu bearbeiten.
Ich musste folgende Änderungen vornehmen:

Code:

---

Private Sub KillOldVersions()
    Dim sRootFolder As String
    sRootFolder = "" ' <------------- Wurzelpfad eintragen
 
    Dim sSearchFolder As String
    sSearchFolder = "OldVersions"
 
    Dim oFSO As FileSystemObject
    Set oFSO = CreateObject("Scripting.FileSystemObject")
 
    Dim oFolder As Folder
    Set oFolder = oFSO.GetFolder(sRootFolder)
 
    Call TraverseFolder (oFSO, oFolder, sSearchFolder)
End Sub
Private Sub TraverseFolder(ByRef oFSO As FileSystemObject, ByVal oFolder As Folder, ByVal sSearchFolder As String)

    Dim sFolder As String
    sFolder = oFolder.Path

    'Durchlauf aller Unterverzeichnisse
    Dim oSubFolder As Folder
    For Each oSubFolder In oFolder.SubFolders
        Call TraverseFolder (oFSO, oSubFolder, sSearchFolder)
    Next
 
    If oFolder.Name = sSearchFolder Then
        'Alle Dateien im Ordner löschen
        Dim oFile As Object
        For Each oFile In oFolder.Files
            Debug.Print oFile.Path
            oFSO.DeleteFile oFile.Path, True '<------------- aktivieren, wenn Test erfolgreich
        Next
     
        'OldVersions Verzeichnis löschen
        If oFolder.Files.Count = 0 And oFolder.SubFolders.Count = 0 Then  '<------------- aktivieren, wenn Test erfolgreich
            Debug.Print oFolder.Path
            oFolder.Delete vbTrue '<------------- aktivieren, wenn Test erfolgreich
        End If '<------------- aktivieren, wenn Test erfolgreich
    End If
 
End Sub

---

Beim Aufruf der Sub "TraverseFolder" im Hauptprogramm habe ich das "Call" und die Klammern um die Parameter eingefügt.

Beim rekursiven Aufruf der Sub "TraverseFolder" im Unterprogramm habe ich das "Call" und die Klammern um die Parameter, sowie den ersten Parameter oFSO eingefügt.

So scheint es zu funktionieren. 

Eine Frage habe ich noch.
Das funktioniert ja nur, wenn "Microsoft Scripting Runtime" geladen wurde. Ich müsste also sicherstellen, dass dies bei allen Anwendern geladen wurde.
Kann man nicht "Microsoft Scripting Runtime" direkt aus VBA laden und hinterher wieder rausnehmen?

.

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hallo

Ich hab aus diesem Thread was geklaut und ein bißchen angepasst.

Code:

---

Option Explicit

Private Sub Main()
'Dummysub, normalerweise kommt der Aufruf aus dem Hauptprogramm
    Call AddReferences(ThisApplication)
End Sub

Private Sub Main2()
'Dummysub, normalerweise kommt der Aufruf aus dem Hauptprogramm
    Call RemoveReferences(ThisApplication)
End Sub

Private Sub AddReferences(Optional ByVal InvApp As Inventor.Application = Nothing)
   
    If InvApp Is Nothing Then Set InvApp = ThisApplication
   
    ' Run DebugPrintExistingRefs in the immediate pane, to show guids of existing references
    AddRef InvApp, "{420B2830-E718-11CF-893D-00A0C9054228}", "Scripting"
    'AddRef wbk, "{00025E01-0000-0000-C000-000000000046}", "DAO"
    'AddRef wbk, "{00020905-0000-0000-C000-000000000046}", "Word"
    'AddRef wbk, "{91493440-5A91-11CF-8700-00AA0060263B}", "PowerPoint"
End Sub

Private Sub AddRef(InvApp As Inventor.Application, sGuid As String, sRefName As String)
    Dim i As Integer
    On Error GoTo EH
    With InvApp.VBE.VBProjects(1).References
        For i = 1 To .Count
            If .Item(i).Name = sRefName Then
              Exit For
            End If
        Next i
        If i > .Count Then
          .AddFromGuid sGuid, 0, 0 ' 0,0 should pick the latest version installed on the computer
        End If
    End With
EX: Exit Sub
EH: MsgBox "Error in 'AddRef'" & vbCrLf & vbCrLf & Err.Description
    Resume EX
    Resume ' debug code
End Sub

Private Sub RemoveReferences(Optional ByVal InvApp As Inventor.Application = Nothing)
    If InvApp Is Nothing Then Set InvApp = ThisApplication
    RemRef InvApp, "{420B2830-E718-11CF-893D-00A0C9054228}", "Scripting"
End Sub

Private Sub RemRef(InvApp As Inventor.Application, sGuid As String, sRefName As String)
    Dim i As Integer
    On Error GoTo EH
    With InvApp.VBE.VBProjects(1).References
        For i = 1 To .Count
            If .Item(i).Name = sRefName Then
              Exit For
            End If
        Next i
        .Remove .Item(i)
    End With
EX: Exit Sub
EH: MsgBox "Error in 'RemRef'" & vbCrLf & vbCrLf & Err.Description
    Resume EX
    Resume ' debug code
End Sub

Private Sub DebugPrintExistingRefs()
'Druckt eine Liste der aktuell geladenen Referenzen ins Direktfenster
'Damit findet man sehr leicht die GUID und den Namen der Reference
    Dim i As Integer
    With ThisApplication.VBE.VBProjects(1).References
        For i = 1 To .Count
            Debug.Print "    AddRef InvApp, """ & .Item(i).GUID & """, """ & .Item(i).Name & """"
        Next i
    End With
End Sub

---

------------------
MfG
Ralf

RKW Solutions GmbH
www.RKW-Solutions.com

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP