Problem :

Zur Verknüpfung von Dokumenten an einen Ordner empfiehlt es sich Ordner anzulegen. Wie mache ich das, wenn ich die Ordner automatisiert per VBA anlegen will?

Lösung :

Wir können zum einen Ordner für die ausgewählten Vorgänge anlegen

Sub Ordneranlegen()
Dim tsk As task, vAblage As String


vAblage = ActiveProject.Path & "\"
For Each tsk In ActiveSelection.Tasks

MkDir vAblage & tsk.Name

Next
End Sub

Alternativ können wir auch Ordner für alle markierten Vorgänge im Projekt anlegen und dabei die Gliederung zu berücksichtigen.

Sub CreateFoldersFromWBS()

    Dim t As Task
    Dim wbs As String
    Dim path As String
    Dim BasePath As String
    Dim i As Integer
    Dim elements() As String
    Dim currentPath As String

    '*** Pfad ggf. anpassen ***
    BasePath = "C:\ProjectFolders" ' Zielordner
    
    ' *** Grundordner anlegen, falls nicht vorhanden ***
    If Dir(BasePath, vbDirectory) = "" Then
        MkDir BasePath
    End If

    For Each t In ActiveProject.Tasks
        If Not t Is Nothing Then
            If t.Summary = False Or t.OutlineLevel = 1 Then
                If Trim(t.Name) <> "" Then

                    ' *** WBS-Nummer (z. B. "1.2.3")  ***
                    wbs = t.OutlineNumber

                    ' *** WBS zerlegen  ***
                    elements = Split(wbs, ".")

                    ' *** Pfad Stück für Stück aufbauen  ***
                    currentPath = BasePath
                    
                    For i = LBound(elements) To UBound(elements)
                        
                        ' *** Name des jeweiligen Abschnitts = OutlineNumber bis zur aktuellen Ebene  ***
                        Dim levelWBS As String
                        levelWBS = Join$(Split(wbs, ".", i + 1), ".")
                        
                        ' *** passenden Vorgang zur aktuellen Ebene finden  ***
                        Dim t2 As Task
                        For Each t2 In ActiveProject.Tasks
                            If Not t2 Is Nothing Then
                                If t2.OutlineNumber = levelWBS Then
                                    
                                    ' Ordnername = "WBS - Vorgangsname"
                                    currentPath = currentPath & "\" & levelWBS & " - " & CleanFileName(t2.Name)
                                    
                                    ' Ordner anlegen, wenn nötig
                                    If Dir(currentPath, vbDirectory) = "" Then
                                        MkDir currentPath
                                    End If
                                    
                                    Exit For
                                End If
                            End If
                        Next t2
                    Next i
                    
                End If
            End If
        End If
    Next t

    MsgBox "Ordnerstruktur erfolgreich erstellt!", vbInformation

End Sub


' *** Hilfsfunktion: Ungültige Ordnerzeichen entfernen  ***
Function CleanFileName(fname As String) As String
    Dim invalidChars As Variant
    invalidChars = Array("\", "/", ":", "*", "?", """", "<", ">", "|")
    
    Dim c As Variant
    For Each c In invalidChars
        fname = Replace(fname, c, "_")
    Next
    CleanFileName = fname
End Function