' Den aktuellen Benutzer ermitteln
Dim AktuellerBenutzer 
Set Testobjekt = CreateObject("WScript.Network")
AktuellerBenutzer = Testobjekt.UserName
MsgBox "Im Moment ist der User " & AktuellerBenutzer & " angemeldet."
 
' Word Neuen Dokumentenpfad setzen
Const wdDocumentsPath = 0
Set objWord = CreateObject("Word.Application")
Set objOptions = objWord.Options
objOptions.DefaultFilePath(0) = Verzeichnis_erstellen("Q:\Home\" & _
  AktuellerBenutzer & "\Word")
objOptions.DefaultFilePath(2) = Verzeichnis_erstellen("Q:\Home\" & _
AktuellerBenutzer & "\Word\Vorlagen")
objOptions.DefaultFilePath(3) = "Q:\BF\BF-V\BF-V_ALL\Word Vorlagen Neu" 
objOptions.DefaultFilePath(8) = "Q:\BF\BF-V\BF-V_ALL\Word Vorlagen" & _
  "Neu\Startup2010"
 
 
' Ergebnis anzeigen
' wdDocumentsPath = 0
' wdUserTemplatesPath = 2
' wdUserOptionsPath = 4
' wdPicturesPath = 1
' wdAutoRecoverPath = 5
' wdStartupPath = 8
' wdWorkgroupTemplatesPath = 3
 
MsgBox ("Word Aktueller Benutzer: " & AktuellerBenutzer & vbCrLf & _
        "Dokumente " & objOptions.DefaultFilePath(0) & vbCrLf & _
        "Clipart-Bilder " & objOptions.DefaultFilePath(1) & vbCrLf &  _
        "Benutzervorlagen " & objOptions.DefaultFilePath(2) & vbCrLf &  _
        "Arbeitsgruppenvorlagen " & objOptions.DefaultFilePath(3) & vbCrLf & _
        "AutoWiederherstellen-Dateien " & objOptions.DefaultFilePath(5) & _
        vbCrLf &  _
        "Wörterbuch " & objOptions.DefaultFilePath(6) & vbCrLf &  _
        "Autostart " & objOptions.DefaultFilePath(8))
objWord.Quit
 
' Excel Neuen Dokumentenpfad setzen
Set objExcel = CreateObject("Excel.Application")
'Set objOptions = objExcel.Options
objExcel.application.DefaultFilePath  = Verzeichnis_erstellen( _
  "Q:\Home\Bungev\Excel")
 
' Ergebnis anzeigen
MsgBox ("Excel Aktueller Benutzer: " & AktuellerBenutzer & vbCrLf & _
        "Dokumente " & objExcel.application.DefaultFilePath)
objExcel.Quit
 
public Function Verzeichnis_erstellen(Verzeichnis)
    Set oFSO = CreateObject("Scripting.FileSystemObject")
 
    ' prüfen ob der Pfad existiert.
    ' Wenn er nicht existiert, weitermachen...
    If NOT oFSO.FolderExists(verzeichnis) Then
        ' ...Pfad zerlegen und nach und nach zusammen setzen
       arrPath = Split(verzeichnis,"\")
        oPath = ""
        For i = 0 To UBound(arrPath)
            ' sicherstellen das der Pfad richtig zusammengesetzt wird
           If oPath = "" Then
                oPath = arrPath(i)
            Else
                oPath = oPath & "\" & arrPath(i)
            End If
            ' prüfen ob der zusammengesetzte Pfad existiert
           ' Wenn er nicht existiert, Pfad erstellen,
           ' sonst weitermachen mit dem nächsten...
           If NOT oFSO.FolderExists(oPath) Then
                oFSO.CreateFolder(oPath)
            End If
        Next
    End If
 
    Set oFSO = Nothing
 
  Verzeichnis_erstellen = Verzeichnis
end Function