Thema: FSO.CreateFolder

Moin Zusammen,
schienbar stehe ich auf dem Schlauch und bitte um Hilfe :)
Ich speichere einen Outlook Ordner mittels VBA auf die Festplatte und habe dafür einen VBA im Netz gefunden. Benutzt wird der Befehl FSO.CreateFolder (Name/Pfad)
wenn es keinen Ordner gibt der den Namen hat.
ich bekomme jedoch eine Fehlermeldung Path does not exist.
Also es handelt sich um einen Ordner aus dem Posteingang + Unterordner
Sprich der Name ist Posteingang\UnterordnerA
Beim Dialog zum speichern selektiere ich das Laufwerk H:\OrdnerB
Fehlermeldung Path does not exist
Wenn ich den Ordner Posteingang in "H:\OrdnerB\Posteingang" schon vorab erstelle läuft der Code und speichert den UnterordnerA dort.
Gibt es hierzu eine alternative, so dass er den Ordner Posteingang + UnterordnerA erstellt ohne vorher den Posteingang als Ornder anzulegen ?

For i = 1 To Folders.Count
StrFolder = StripIllegalChar(Folders(i))
n = InStr(3, StrFolder, "\") + 1
StrFolder = Mid(StrFolder, n, 256)
StrFolderPath = StrSavePath & StrFolder & "\"
StrSaveFolder = Left(StrFolderPath, Len(StrFolderPath) - 1) & "\"
If Not FSO.FolderExists(StrFolderPath) Then
FSO.CreateFolder (StrFolderPath)
End If
Set SubFolder = myOlApp.Session.GetFolderFromID(EntryID(i), StoreID(i))
On Error Resume Next

Hi
Google mal nach
MakeSureDirectoryPathExists
ist ne API-Funktion, dh erklären kann ich dir es nicht.
damit kann man aber die Verzeichnisstruktur direkt erstellen, ohne jeden einzelnen Unterordner erstellen zu müssen.
Gruß Daniel

Hi Daniel,
danke, ich werd mir das denke ich ganz in Ruhe mal anschauen.
Leider konnte ich das auf anhieb nicht einbinden bzw ersetzen.
Jemand schon ne Lösung für mich damit ich in Ruhe schlafen kann ?

Hi zusammen,
die API-Funktion wurde hier von Sepp erklärt:
https://www.herber.de/forum/archiv/708to712/708450_Ordner_erstellen_mit_VBA_Code_anpassen.html
Zum Spielen kopiere Dir bitte mal das in ein Modul:

'API Deklaration~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" ( _
ByVal DirPath As String) As Long
'Ende API Deklaration~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Sub DirTestSepp()
Dim ordner$
Dim i&
ordner = Range("A2").Value       ' hier gibst Du testweise Pfade ein
If Right(ordner, 1) <> "\" Then ordner = ordner & "\"
i = MakeSureDirectoryPathExists(ordner)
If i <> 0 Then
MsgBox "Pfad existiert spätestens jetzt, ab hier beliebige Aktion"
Else
MsgBox "Pfad konnte nicht erstellt werden!", 48, "Hinweis"
End If
End Sub
Sub OderDirTest() ' Variante mit Zwischenergebnissen im Debug-Fenster
Dim ordner$, test$, ergebnis$
Dim i&
Dim oa
ordner = Range("A2").Value       ' hier gibst Du testweise Pfade ein
oa = Split(ordner, "\")
For i = 0 To UBound(oa): Debug.Print i & ": " & oa(i): Next
'Stop
test = oa(0) & "\"
For i = 1 To UBound(oa)
test = test & oa(i)
ergebnis = Dir(test, vbDirectory)
Debug.Print i & ": " & ergebnis
If ergebnis = "" Then MkDir test
If i < UBound(oa) Then test = test & "\"
Next
End Sub

Die obere Funktion ist die Variante von Sepp, die untere ist nicht ganz ausgereift, weil sie nicht zwischen Ordnern und Dateinamen unterscheidet, aber Du kannst im Debug-Fenster bzw. beim Durchgehen des Codes mit F8 schrittweise nachvollziehen, was passiert.
Das alles in Deinen Code einzubauen scheitert daran, daß wir ja nicht wissen, was wann in welchen Deiner Variablen steht.
Die zweite Zeile verstehe ich ohnehin nicht: zuerst schneidest Du das letzte Zeichen ab, das ja wegen der Zeile vorher bekanntlich ein \ ist, und dann hängst Du wieder ein \ an.

StrFolderPath = StrSavePath & StrFolder & "\"
StrSaveFolder = Left(StrFolderPath, Len(StrFolderPath) - 1) & "\"

Schöne Grüße,
Michael

Hi
wenn du dich nicht mit den Tiefen des Betriebssystems auseinandersezten willst, dann kann man sich auch eine kleine Funktion schreiben, die das erledigt:

Sub PfadErstellen(Pfad As String)
Dim PfadTeile
Dim Pfad1
Dim i As Long
PfadTeile = Split(Pfad, "\")
Pfad1 = PfadTeile(0)
For i = 1 To UBound(PfadTeile)
Pfad1 = Pfad1 & "\" & PfadTeile(i)
If Dir(Pfad1, vbDirectory) = "" Then MkDir Pfad1
Next
End Sub

diesen Code in ein allgemeines Modul und bei Bedarf einfach aufrufen mit

Call PfadErstellen("C:\Ordern1\Ordner2\Ordner3")

Gruß Daniel

Guten Morgen Daniel,
besten Dank für deine Mühe!!!
Anbei mal der ganze Code. Es gehthier speziell um den Teil ab For I.
Könnte man den Teil direkt dort einbauen ? FSO.CreateFolder durch den Call zu ersetzen funktionierte leider nicht. Erstellt werden soll Ordner + Unterordner in einem ausgewählten Laufwerk per Dialog

Option Explicit
Public lf As New LogFile
Sub SaveAllEmails_ProcessAllSubFolders()
Dim i               As Long
Dim j               As Long
Dim n               As Long
Dim StrSubject      As String
Dim StrName         As String
Dim StrFile         As String
Dim StrReceived     As String
Dim StrSavePath     As String
Dim StrFolder       As String
Dim StrFolderPath   As String
Dim StrSaveFolder   As String
Dim Prompt          As String
Dim Title           As String
Dim iNameSpace      As NameSpace
Dim myOlApp         As Outlook.Application
Dim SubFolder       As MAPIFolder
Dim mItem           As MailItem
Dim FSO             As Object
Dim ChosenFolder    As Object
Dim Folders         As New Collection
Dim EntryID         As New Collection
Dim StoreID         As New Collection
Set FSO = CreateObject("Scripting.FileSystemObject")
Set myOlApp = Outlook.Application
Set iNameSpace = myOlApp.GetNamespace("MAPI")
Set ChosenFolder = iNameSpace.PickFolder
If ChosenFolder Is Nothing Then
GoTo ExitSub:
End If
Prompt = "Please enter the path to save all the emails to."
Title = "Folder Specification"
StrSavePath = BrowseForFolder
If StrSavePath = "" Then
GoTo ExitSub:
End If
If Not Right(StrSavePath, 1) = "\" Then
StrSavePath = StrSavePath & "\"
End If
lf.name = StrSavePath + "Post.log"
Call GetFolder(Folders, EntryID, StoreID, ChosenFolder)
For i = 1 To Folders.Count
StrFolder = StripIllegalChar(Folders(i))
n = InStr(3, StrFolder, "\") + 1
StrFolder = Mid(StrFolder, n, 256)
StrFolderPath = StrSavePath & StrFolder & "\"
StrSaveFolder = Left(StrFolderPath, Len(StrFolderPath) - 1) & "\"
If Not FSO.FolderExists(StrFolderPath) Then
FSO.CreateFolder (StrFolderPath)
End If
Set SubFolder = myOlApp.Session.GetFolderFromID(EntryID(i), StoreID(i))
On Error Resume Next
For j = 1 To SubFolder.Items.Count
Set mItem = SubFolder.Items(j)
'            StrReceived = ArrangedDate(mItem.ReceivedTime)
StrReceived = Format(mItem.ReceivedTime, "yyyy-mm-dd_hh-nn-ss")
StrSubject = mItem.Subject
StrName = StripIllegalChar(StrSubject)
StrFile = StrSaveFolder & StrReceived & "_" & StrName
StrFile = Left(StrFile, 200) & ".msg"
lf.LFInfo StrReceived & "<|>" & StrName & "<|>" & mItem.Sender.name & "<|>" & mItem. _
To & "<|>" & mItem.CC & "<|>" & StrFile
mItem.SaveAs StrFile, 3
Next j
On Error GoTo 0
Next i
ExitSub:
End Sub
Function StripIllegalChar(StrInput)
Dim RegX            As Object
Set RegX = CreateObject("vbscript.regexp")
RegX.Pattern = "[\" & Chr(34) & Chr(10) & Chr(13) & "\!\@\#\$\%\^\&\*\(\)\=\+\|\[\]\{\}\`\'\ _
;\:\<\>\?\/\,]"
RegX.IgnoreCase = True
RegX.Global = True
StripIllegalChar = RegX.Replace(StrInput, "")
ExitFunction:
Set RegX = Nothing
End Function
Function ArrangedDate(StrDateInput)
Dim StrFullDate     As String
Dim StrFullTime     As String
Dim StrAMPM         As String
Dim StrTime         As String
Dim StrYear         As String
Dim StrMonthDay     As String
Dim StrMonth        As String
Dim StrDay          As String
Dim StrDate         As String
Dim StrDateTime     As String
Dim RegX            As Object
Set RegX = CreateObject("vbscript.regexp")
If Not Left(StrDateInput, 2) = "10" And _
Not Left(StrDateInput, 2) = "11" And _
Not Left(StrDateInput, 2) = "12" Then
StrDateInput = "0" & StrDateInput
End If
StrFullDate = Left(StrDateInput, 10)
If Right(StrFullDate, 1) = " " Then
StrFullDate = Left(StrDateInput, 9)
End If
StrFullTime = Replace(StrDateInput, StrFullDate & " ", "")
If Len(StrFullTime) = 10 Then
StrFullTime = "0" & StrFullTime
End If
StrAMPM = Right(StrFullTime, 2)
StrTime = StrAMPM & "-" & Left(StrFullTime, 8)
StrYear = Right(StrFullDate, 4)
StrMonthDay = Replace(StrFullDate, "/" & StrYear, "")
StrMonth = Left(StrMonthDay, 2)
StrDay = Right(StrMonthDay, Len(StrMonthDay) - 3)
If Len(StrDay) = 1 Then
StrDay = "0" & StrDay
End If
StrDate = StrYear & "-" & StrMonth & "-" & StrDay
StrDateTime = StrDate & "_" & StrTime
RegX.Pattern = "[\:\/\ ]"
RegX.IgnoreCase = True
RegX.Global = True
ArrangedDate = RegX.Replace(StrDateTime, "-")
ExitFunction:
Set RegX = Nothing
End Function
Sub GetFolder(Folders As Collection, EntryID As Collection, StoreID As Collection, Fld As  _
MAPIFolder)
Dim SubFolder       As MAPIFolder
Folders.Add Fld.FolderPath
EntryID.Add Fld.EntryID
StoreID.Add Fld.StoreID
For Each SubFolder In Fld.Folders
GetFolder Folders, EntryID, StoreID, SubFolder
Next SubFolder
ExitSub:
Set SubFolder = Nothing
End Sub
Function BrowseForFolder(Optional OpenAt As String) As String
Dim ShellApp As Object
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then
BrowseForFolder = ""
End If
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then
BrowseForFolder = ""
End If
Case Else
BrowseForFolder = ""
End Select
ExitFunction:
Set ShellApp = Nothing
End Function

Guten Morgen Zusammen,
vielleicht hat jemand anderes noch Zeit mir zu helfen ?
Ich würde gerne den Teil ersetzen:

For i = 1 To Folders.Count
StrFolder = StripIllegalChar(Folders(i))
n = InStr(3, StrFolder, "\") + 1
StrFolder = Mid(StrFolder, n, 256)
StrFolderPath = StrSavePath & StrFolder & "\"
StrSaveFolder = Left(StrFolderPath, Len(StrFolderPath) - 1) & "\"
If Not FSO.FolderExists(StrFolderPath) Then
FSO.CreateFolder (StrFolderPath)

Das Makro soll einen ausgewählten Ordner aus Outlook auf die Festplatte speichern.
Dabei wird geprüft ob der Pfad = StrFolderPath als Ordner auf der Festplatte existiert.
Wenn nicht soll dieser über FSO.CreateFolder erstellt werden.
Hier gibt es aber ein Problem:
Wenn ich einen Unterordner aus dem Posteingang wähle ist der Pfad Posteingang\UnterordnerA
Beim Anlegen durchlaufen bleibt der Code an der Stelle stehen und sagt Pfad nicht gefunden.
Wenn ich am Speicherort aber einen Ordner Posteingang erstelle dann erstellt er den UnterordnerA korrekt. Soll bzw. muss aber auch gehen wenn es mehrere Ordnerebenen gibt die er zu erstellen hat.
Genau das sollte ja der Vorteil bei diesem Makro sein.,
Kann jemand helfen ?
Ganzer Code:

Option Explicit
Public lf As New LogFile
Sub SaveAllEmails_ProcessAllSubFolders()
Dim i               As Long
Dim j               As Long
Dim n               As Long
Dim StrSubject      As String
Dim StrName         As String
Dim StrFile         As String
Dim StrReceived     As String
Dim StrSavePath     As String
Dim StrFolder       As String
Dim StrFolderPath   As String
Dim StrSaveFolder   As String
Dim Prompt          As String
Dim Title           As String
Dim iNameSpace      As NameSpace
Dim myOlApp         As Outlook.Application
Dim SubFolder       As MAPIFolder
Dim mItem           As MailItem
Dim FSO             As Object
Dim ChosenFolder    As Object
Dim Folders         As New Collection
Dim EntryID         As New Collection
Dim StoreID         As New Collection
Set FSO = CreateObject("Scripting.FileSystemObject")
Set myOlApp = Outlook.Application
Set iNameSpace = myOlApp.GetNamespace("MAPI")
Set ChosenFolder = iNameSpace.PickFolder
If ChosenFolder Is Nothing Then
GoTo ExitSub:
End If
Prompt = "Please enter the path to save all the emails to."
Title = "Folder Specification"
StrSavePath = BrowseForFolder
If StrSavePath = "" Then
GoTo ExitSub:
End If
If Not Right(StrSavePath, 1) = "\" Then
StrSavePath = StrSavePath & "\"
End If
lf.name = StrSavePath + "Post.log"
Call GetFolder(Folders, EntryID, StoreID, ChosenFolder)
For i = 1 To Folders.Count
StrFolder = StripIllegalChar(Folders(i))
n = InStr(3, StrFolder, "\") + 1
StrFolder = Mid(StrFolder, n, 256)
StrFolderPath = StrSavePath & StrFolder & "\"
StrSaveFolder = Left(StrFolderPath, Len(StrFolderPath) - 1) & "\"
If Not FSO.FolderExists(StrFolderPath) Then
FSO.CreateFolder (StrFolderPath)
End If
Set SubFolder = myOlApp.Session.GetFolderFromID(EntryID(i), StoreID(i))
On Error Resume Next
For j = 1 To SubFolder.Items.Count
Set mItem = SubFolder.Items(j)
'            StrReceived = ArrangedDate(mItem.ReceivedTime)
StrReceived = Format(mItem.ReceivedTime, "yyyy-mm-dd_hh-nn-ss")
StrSubject = mItem.Subject
StrName = StripIllegalChar(StrSubject)
StrFile = StrSaveFolder & StrReceived & "_" & StrName
StrFile = Left(StrFile, 200) & ".msg"
lf.LFInfo StrReceived & "<|>" & StrName & "<|>" & mItem.Sender.name & "<|>" & mItem. _
To & "<|>" & mItem.CC & "<|>" & StrFile
mItem.SaveAs StrFile, 3
Next j
On Error GoTo 0
Next i
ExitSub:
End Sub
Function StripIllegalChar(StrInput)
Dim RegX            As Object
Set RegX = CreateObject("vbscript.regexp")
RegX.Pattern = "[\" & Chr(34) & Chr(10) & Chr(13) & "\!\@\#\$\%\^\&\*\(\)\=\+\|\[\]\{\}\`\'\ _
;\:\<\>\?\/\,]"
RegX.IgnoreCase = True
RegX.Global = True
StripIllegalChar = RegX.Replace(StrInput, "")
ExitFunction:
Set RegX = Nothing
End Function
Function ArrangedDate(StrDateInput)
Dim StrFullDate     As String
Dim StrFullTime     As String
Dim StrAMPM         As String
Dim StrTime         As String
Dim StrYear         As String
Dim StrMonthDay     As String
Dim StrMonth        As String
Dim StrDay          As String
Dim StrDate         As String
Dim StrDateTime     As String
Dim RegX            As Object
Set RegX = CreateObject("vbscript.regexp")
If Not Left(StrDateInput, 2) = "10" And _
Not Left(StrDateInput, 2) = "11" And _
Not Left(StrDateInput, 2) = "12" Then
StrDateInput = "0" & StrDateInput
End If
StrFullDate = Left(StrDateInput, 10)
If Right(StrFullDate, 1) = " " Then
StrFullDate = Left(StrDateInput, 9)
End If
StrFullTime = Replace(StrDateInput, StrFullDate & " ", "")
If Len(StrFullTime) = 10 Then
StrFullTime = "0" & StrFullTime
End If
StrAMPM = Right(StrFullTime, 2)
StrTime = StrAMPM & "-" & Left(StrFullTime, 8)
StrYear = Right(StrFullDate, 4)
StrMonthDay = Replace(StrFullDate, "/" & StrYear, "")
StrMonth = Left(StrMonthDay, 2)
StrDay = Right(StrMonthDay, Len(StrMonthDay) - 3)
If Len(StrDay) = 1 Then
StrDay = "0" & StrDay
End If
StrDate = StrYear & "-" & StrMonth & "-" & StrDay
StrDateTime = StrDate & "_" & StrTime
RegX.Pattern = "[\:\/\ ]"
RegX.IgnoreCase = True
RegX.Global = True
ArrangedDate = RegX.Replace(StrDateTime, "-")
ExitFunction:
Set RegX = Nothing
End Function
Sub GetFolder(Folders As Collection, EntryID As Collection, StoreID As Collection, Fld As  _
MAPIFolder)
Dim SubFolder       As MAPIFolder
Folders.Add Fld.FolderPath
EntryID.Add Fld.EntryID
StoreID.Add Fld.StoreID
For Each SubFolder In Fld.Folders
GetFolder Folders, EntryID, StoreID, SubFolder
Next SubFolder
ExitSub:
Set SubFolder = Nothing
End Sub
Function BrowseForFolder(Optional OpenAt As String) As String
Dim ShellApp As Object
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then
BrowseForFolder = ""
End If
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then
BrowseForFolder = ""
End If
Case Else
BrowseForFolder = ""
End Select
ExitFunction:
Set ShellApp = Nothing
End Function

Hi
du musst die Sub "PfadErstellen" in ein allgemeines Modul schreiben und dann
diesen Code:

If Not FSO.FolderExists(StrFolderPath) Then
FSO.CreateFolder (StrFolderPath)
End If

durch diesen ersetzen:

Call PfadErstellen(StrFolderPath)

die Prüfung, ob der Pfad schon vorhanden ist, ist nicht notwendig, denn dann läuft die Sub einfach durch.
allerdings sollte bei StrFolderPath kein "\" am Ende stehen.
oder du musst die Sub noch so eränzen:

Sub PfadErstellen(Pfad As String)
Dim PfadTeile
Dim Pfad1
Dim i As Long
PfadTeile = Split(Left(Pfad),Len(Pfad) - IIF(Right(Pfad, 1)="\",1,0)), "\")
Pfad1 = PfadTeile(0)

gruß Daniel

ich Depp!! Danke Daniel!!!!! Jetzt funkts.

Hi Daniel,
beim testen ist mitr gerad aufgefallen wenn man mehrere Unterordner hat siehts auf der Festplatte doch ziemlich wild aus.
C:\Posteingang\UnterornderA\UnterordnerB\UnterordnerC\etc
Wie müsste ich die deklaration im Pfad änder, so dass er wirklich nur den letzten UnterordnerC ohne den kompletten Pfad erstellt ?

Hi
ein Computerprogramm kann nicht hellsehen.
du musst immer genau die Ordnerstruktur angeben, die du auch haben willst.
wenn du den UnterordnerC haben willst, dann solltest du schon wissen, in welchem Übergeordneten Verzeichnis du den Ordner haben willst und wenn der UnterordnerC im UnterordnerA erscheinen soll, dann darfst du auch nur das angeben:
"C:\Posteingang\UnterornderA\UnterordnerC"
mein Programm erstellt immer genau die Ordnerstrukutr, die du vorgibst.
Gruß Daniel

Hi Daniel,
ja klar verstehe ich das schon,
Also gespeichert hat er den kompletten Pfad und legt diese an.
Das ist ja soweit auch genau richtig.
Was müsste man ändern damit er jetzt nur noch den letzten Ordner als Pfad nimmt ?
C:\unterordnerC
statt
C:\Posteingang\UnterornderA\UnterordnerB\UnterordnerC\etc
In dem eigentlich Code ist ChosenFolder deklariert, der genau nur diese Bezeichnung hat.
Wenn ich jedoch
StrFolderPath = StrFolder & "\"
durch
StrFolderPath = ChosenFolder & "\"
ersetze bekomme ich einen Fehler beim Zugriff auf Pfad/Datei und makiert bei MkDir Pfad1
MkDir Pfad1 zeigt aber eigentlich nur noch UnterordnerC korrekt an...

Hi
wenn du aus:
"C:\Posteingang\UnterornderA\UnterordnerB\UnterordnerC"
"C:\UnterordnerC"
machen willst dann:

Pfad1 = "C:\Posteingang\UnterornderA\UnterordnerB\UnterordnerC"
Pfad2 = Left(Pfad1, 2) & Right(Pfad1, InstrRev(Pfad1, "\"))

dann wird aber der UnterornderC direkt ins RootVerzeichnis gestellt.
Gruß Daniel

Moin Zusammen,
schienbar stehe ich auf dem Schlauch und bitte um Hilfe :)
Ich speichere einen Outlook Ordner mittels VBA auf die Festplatte und habe dafür einen VBA im Netz gefunden. Benutzt wird der Befehl FSO.CreateFolder (Name/Pfad)
wenn es keinen Ordner gibt der den Namen hat.
ich bekomme jedoch eine Fehlermeldung Path does not exist.
Also es handelt sich um einen Ordner aus dem Posteingang + Unterordner
Sprich der Name ist Posteingang\UnterordnerA
Beim Dialog zum speichern selektiere ich das Laufwerk H:\OrdnerB
Fehlermeldung Path does not exist
Wenn ich den Ordner Posteingang in "H:\OrdnerB\Posteingang" schon vorab erstelle läuft der Code und speichert den UnterordnerA dort.
Gibt es hierzu eine alternative, so dass er den Ordner Posteingang + UnterordnerA erstellt ohne vorher den Posteingang als Ornder anzulegen ?

For i = 1 To Folders.Count
StrFolder = StripIllegalChar(Folders(i))
n = InStr(3, StrFolder, "\") + 1
StrFolder = Mid(StrFolder, n, 256)
StrFolderPath = StrSavePath & StrFolder & "\"
StrSaveFolder = Left(StrFolderPath, Len(StrFolderPath) - 1) & "\"
If Not FSO.FolderExists(StrFolderPath) Then
FSO.CreateFolder (StrFolderPath)
End If
Set SubFolder = myOlApp.Session.GetFolderFromID(EntryID(i), StoreID(i))
On Error Resume Next

Hi
Google mal nach
MakeSureDirectoryPathExists
ist ne API-Funktion, dh erklären kann ich dir es nicht.
damit kann man aber die Verzeichnisstruktur direkt erstellen, ohne jeden einzelnen Unterordner erstellen zu müssen.
Gruß Daniel

Hi Daniel,
danke, ich werd mir das denke ich ganz in Ruhe mal anschauen.
Leider konnte ich das auf anhieb nicht einbinden bzw ersetzen.
Jemand schon ne Lösung für mich damit ich in Ruhe schlafen kann ?

Hi zusammen,
die API-Funktion wurde hier von Sepp erklärt:
https://www.herber.de/forum/archiv/708to712/708450_Ordner_erstellen_mit_VBA_Code_anpassen.html
Zum Spielen kopiere Dir bitte mal das in ein Modul:

'API Deklaration~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" ( _
ByVal DirPath As String) As Long
'Ende API Deklaration~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Sub DirTestSepp()
Dim ordner$
Dim i&
ordner = Range("A2").Value       ' hier gibst Du testweise Pfade ein
If Right(ordner, 1) <> "\" Then ordner = ordner & "\"
i = MakeSureDirectoryPathExists(ordner)
If i <> 0 Then
MsgBox "Pfad existiert spätestens jetzt, ab hier beliebige Aktion"
Else
MsgBox "Pfad konnte nicht erstellt werden!", 48, "Hinweis"
End If
End Sub
Sub OderDirTest() ' Variante mit Zwischenergebnissen im Debug-Fenster
Dim ordner$, test$, ergebnis$
Dim i&
Dim oa
ordner = Range("A2").Value       ' hier gibst Du testweise Pfade ein
oa = Split(ordner, "\")
For i = 0 To UBound(oa): Debug.Print i & ": " & oa(i): Next
'Stop
test = oa(0) & "\"
For i = 1 To UBound(oa)
test = test & oa(i)
ergebnis = Dir(test, vbDirectory)
Debug.Print i & ": " & ergebnis
If ergebnis = "" Then MkDir test
If i < UBound(oa) Then test = test & "\"
Next
End Sub

Die obere Funktion ist die Variante von Sepp, die untere ist nicht ganz ausgereift, weil sie nicht zwischen Ordnern und Dateinamen unterscheidet, aber Du kannst im Debug-Fenster bzw. beim Durchgehen des Codes mit F8 schrittweise nachvollziehen, was passiert.
Das alles in Deinen Code einzubauen scheitert daran, daß wir ja nicht wissen, was wann in welchen Deiner Variablen steht.
Die zweite Zeile verstehe ich ohnehin nicht: zuerst schneidest Du das letzte Zeichen ab, das ja wegen der Zeile vorher bekanntlich ein \ ist, und dann hängst Du wieder ein \ an.

StrFolderPath = StrSavePath & StrFolder & "\"
StrSaveFolder = Left(StrFolderPath, Len(StrFolderPath) - 1) & "\"

Schöne Grüße,
Michael

Hi
wenn du dich nicht mit den Tiefen des Betriebssystems auseinandersezten willst, dann kann man sich auch eine kleine Funktion schreiben, die das erledigt:

Sub PfadErstellen(Pfad As String)
Dim PfadTeile
Dim Pfad1
Dim i As Long
PfadTeile = Split(Pfad, "\")
Pfad1 = PfadTeile(0)
For i = 1 To UBound(PfadTeile)
Pfad1 = Pfad1 & "\" & PfadTeile(i)
If Dir(Pfad1, vbDirectory) = "" Then MkDir Pfad1
Next
End Sub

diesen Code in ein allgemeines Modul und bei Bedarf einfach aufrufen mit

Call PfadErstellen("C:\Ordern1\Ordner2\Ordner3")

Gruß Daniel

Guten Morgen Daniel,
besten Dank für deine Mühe!!!
Anbei mal der ganze Code. Es gehthier speziell um den Teil ab For I.
Könnte man den Teil direkt dort einbauen ? FSO.CreateFolder durch den Call zu ersetzen funktionierte leider nicht. Erstellt werden soll Ordner + Unterordner in einem ausgewählten Laufwerk per Dialog

Option Explicit
Public lf As New LogFile
Sub SaveAllEmails_ProcessAllSubFolders()
Dim i               As Long
Dim j               As Long
Dim n               As Long
Dim StrSubject      As String
Dim StrName         As String
Dim StrFile         As String
Dim StrReceived     As String
Dim StrSavePath     As String
Dim StrFolder       As String
Dim StrFolderPath   As String
Dim StrSaveFolder   As String
Dim Prompt          As String
Dim Title           As String
Dim iNameSpace      As NameSpace
Dim myOlApp         As Outlook.Application
Dim SubFolder       As MAPIFolder
Dim mItem           As MailItem
Dim FSO             As Object
Dim ChosenFolder    As Object
Dim Folders         As New Collection
Dim EntryID         As New Collection
Dim StoreID         As New Collection
Set FSO = CreateObject("Scripting.FileSystemObject")
Set myOlApp = Outlook.Application
Set iNameSpace = myOlApp.GetNamespace("MAPI")
Set ChosenFolder = iNameSpace.PickFolder
If ChosenFolder Is Nothing Then
GoTo ExitSub:
End If
Prompt = "Please enter the path to save all the emails to."
Title = "Folder Specification"
StrSavePath = BrowseForFolder
If StrSavePath = "" Then
GoTo ExitSub:
End If
If Not Right(StrSavePath, 1) = "\" Then
StrSavePath = StrSavePath & "\"
End If
lf.name = StrSavePath + "Post.log"
Call GetFolder(Folders, EntryID, StoreID, ChosenFolder)
For i = 1 To Folders.Count
StrFolder = StripIllegalChar(Folders(i))
n = InStr(3, StrFolder, "\") + 1
StrFolder = Mid(StrFolder, n, 256)
StrFolderPath = StrSavePath & StrFolder & "\"
StrSaveFolder = Left(StrFolderPath, Len(StrFolderPath) - 1) & "\"
If Not FSO.FolderExists(StrFolderPath) Then
FSO.CreateFolder (StrFolderPath)
End If
Set SubFolder = myOlApp.Session.GetFolderFromID(EntryID(i), StoreID(i))
On Error Resume Next
For j = 1 To SubFolder.Items.Count
Set mItem = SubFolder.Items(j)
'            StrReceived = ArrangedDate(mItem.ReceivedTime)
StrReceived = Format(mItem.ReceivedTime, "yyyy-mm-dd_hh-nn-ss")
StrSubject = mItem.Subject
StrName = StripIllegalChar(StrSubject)
StrFile = StrSaveFolder & StrReceived & "_" & StrName
StrFile = Left(StrFile, 200) & ".msg"
lf.LFInfo StrReceived & "<|>" & StrName & "<|>" & mItem.Sender.name & "<|>" & mItem. _
To & "<|>" & mItem.CC & "<|>" & StrFile
mItem.SaveAs StrFile, 3
Next j
On Error GoTo 0
Next i
ExitSub:
End Sub
Function StripIllegalChar(StrInput)
Dim RegX            As Object
Set RegX = CreateObject("vbscript.regexp")
RegX.Pattern = "[\" & Chr(34) & Chr(10) & Chr(13) & "\!\@\#\$\%\^\&\*\(\)\=\+\|\[\]\{\}\`\'\ _
;\:\<\>\?\/\,]"
RegX.IgnoreCase = True
RegX.Global = True
StripIllegalChar = RegX.Replace(StrInput, "")
ExitFunction:
Set RegX = Nothing
End Function
Function ArrangedDate(StrDateInput)
Dim StrFullDate     As String
Dim StrFullTime     As String
Dim StrAMPM         As String
Dim StrTime         As String
Dim StrYear         As String
Dim StrMonthDay     As String
Dim StrMonth        As String
Dim StrDay          As String
Dim StrDate         As String
Dim StrDateTime     As String
Dim RegX            As Object
Set RegX = CreateObject("vbscript.regexp")
If Not Left(StrDateInput, 2) = "10" And _
Not Left(StrDateInput, 2) = "11" And _
Not Left(StrDateInput, 2) = "12" Then
StrDateInput = "0" & StrDateInput
End If
StrFullDate = Left(StrDateInput, 10)
If Right(StrFullDate, 1) = " " Then
StrFullDate = Left(StrDateInput, 9)
End If
StrFullTime = Replace(StrDateInput, StrFullDate & " ", "")
If Len(StrFullTime) = 10 Then
StrFullTime = "0" & StrFullTime
End If
StrAMPM = Right(StrFullTime, 2)
StrTime = StrAMPM & "-" & Left(StrFullTime, 8)
StrYear = Right(StrFullDate, 4)
StrMonthDay = Replace(StrFullDate, "/" & StrYear, "")
StrMonth = Left(StrMonthDay, 2)
StrDay = Right(StrMonthDay, Len(StrMonthDay) - 3)
If Len(StrDay) = 1 Then
StrDay = "0" & StrDay
End If
StrDate = StrYear & "-" & StrMonth & "-" & StrDay
StrDateTime = StrDate & "_" & StrTime
RegX.Pattern = "[\:\/\ ]"
RegX.IgnoreCase = True
RegX.Global = True
ArrangedDate = RegX.Replace(StrDateTime, "-")
ExitFunction:
Set RegX = Nothing
End Function
Sub GetFolder(Folders As Collection, EntryID As Collection, StoreID As Collection, Fld As  _
MAPIFolder)
Dim SubFolder       As MAPIFolder
Folders.Add Fld.FolderPath
EntryID.Add Fld.EntryID
StoreID.Add Fld.StoreID
For Each SubFolder In Fld.Folders
GetFolder Folders, EntryID, StoreID, SubFolder
Next SubFolder
ExitSub:
Set SubFolder = Nothing
End Sub
Function BrowseForFolder(Optional OpenAt As String) As String
Dim ShellApp As Object
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then
BrowseForFolder = ""
End If
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then
BrowseForFolder = ""
End If
Case Else
BrowseForFolder = ""
End Select
ExitFunction:
Set ShellApp = Nothing
End Function

Guten Morgen Zusammen,
vielleicht hat jemand anderes noch Zeit mir zu helfen ?
Ich würde gerne den Teil ersetzen:

For i = 1 To Folders.Count
StrFolder = StripIllegalChar(Folders(i))
n = InStr(3, StrFolder, "\") + 1
StrFolder = Mid(StrFolder, n, 256)
StrFolderPath = StrSavePath & StrFolder & "\"
StrSaveFolder = Left(StrFolderPath, Len(StrFolderPath) - 1) & "\"
If Not FSO.FolderExists(StrFolderPath) Then
FSO.CreateFolder (StrFolderPath)

Das Makro soll einen ausgewählten Ordner aus Outlook auf die Festplatte speichern.
Dabei wird geprüft ob der Pfad = StrFolderPath als Ordner auf der Festplatte existiert.
Wenn nicht soll dieser über FSO.CreateFolder erstellt werden.
Hier gibt es aber ein Problem:
Wenn ich einen Unterordner aus dem Posteingang wähle ist der Pfad Posteingang\UnterordnerA
Beim Anlegen durchlaufen bleibt der Code an der Stelle stehen und sagt Pfad nicht gefunden.
Wenn ich am Speicherort aber einen Ordner Posteingang erstelle dann erstellt er den UnterordnerA korrekt. Soll bzw. muss aber auch gehen wenn es mehrere Ordnerebenen gibt die er zu erstellen hat.
Genau das sollte ja der Vorteil bei diesem Makro sein.,
Kann jemand helfen ?
Ganzer Code:

Option Explicit
Public lf As New LogFile
Sub SaveAllEmails_ProcessAllSubFolders()
Dim i               As Long
Dim j               As Long
Dim n               As Long
Dim StrSubject      As String
Dim StrName         As String
Dim StrFile         As String
Dim StrReceived     As String
Dim StrSavePath     As String
Dim StrFolder       As String
Dim StrFolderPath   As String
Dim StrSaveFolder   As String
Dim Prompt          As String
Dim Title           As String
Dim iNameSpace      As NameSpace
Dim myOlApp         As Outlook.Application
Dim SubFolder       As MAPIFolder
Dim mItem           As MailItem
Dim FSO             As Object
Dim ChosenFolder    As Object
Dim Folders         As New Collection
Dim EntryID         As New Collection
Dim StoreID         As New Collection
Set FSO = CreateObject("Scripting.FileSystemObject")
Set myOlApp = Outlook.Application
Set iNameSpace = myOlApp.GetNamespace("MAPI")
Set ChosenFolder = iNameSpace.PickFolder
If ChosenFolder Is Nothing Then
GoTo ExitSub:
End If
Prompt = "Please enter the path to save all the emails to."
Title = "Folder Specification"
StrSavePath = BrowseForFolder
If StrSavePath = "" Then
GoTo ExitSub:
End If
If Not Right(StrSavePath, 1) = "\" Then
StrSavePath = StrSavePath & "\"
End If
lf.name = StrSavePath + "Post.log"
Call GetFolder(Folders, EntryID, StoreID, ChosenFolder)
For i = 1 To Folders.Count
StrFolder = StripIllegalChar(Folders(i))
n = InStr(3, StrFolder, "\") + 1
StrFolder = Mid(StrFolder, n, 256)
StrFolderPath = StrSavePath & StrFolder & "\"
StrSaveFolder = Left(StrFolderPath, Len(StrFolderPath) - 1) & "\"
If Not FSO.FolderExists(StrFolderPath) Then
FSO.CreateFolder (StrFolderPath)
End If
Set SubFolder = myOlApp.Session.GetFolderFromID(EntryID(i), StoreID(i))
On Error Resume Next
For j = 1 To SubFolder.Items.Count
Set mItem = SubFolder.Items(j)
'            StrReceived = ArrangedDate(mItem.ReceivedTime)
StrReceived = Format(mItem.ReceivedTime, "yyyy-mm-dd_hh-nn-ss")
StrSubject = mItem.Subject
StrName = StripIllegalChar(StrSubject)
StrFile = StrSaveFolder & StrReceived & "_" & StrName
StrFile = Left(StrFile, 200) & ".msg"
lf.LFInfo StrReceived & "<|>" & StrName & "<|>" & mItem.Sender.name & "<|>" & mItem. _
To & "<|>" & mItem.CC & "<|>" & StrFile
mItem.SaveAs StrFile, 3
Next j
On Error GoTo 0
Next i
ExitSub:
End Sub
Function StripIllegalChar(StrInput)
Dim RegX            As Object
Set RegX = CreateObject("vbscript.regexp")
RegX.Pattern = "[\" & Chr(34) & Chr(10) & Chr(13) & "\!\@\#\$\%\^\&\*\(\)\=\+\|\[\]\{\}\`\'\ _
;\:\<\>\?\/\,]"
RegX.IgnoreCase = True
RegX.Global = True
StripIllegalChar = RegX.Replace(StrInput, "")
ExitFunction:
Set RegX = Nothing
End Function
Function ArrangedDate(StrDateInput)
Dim StrFullDate     As String
Dim StrFullTime     As String
Dim StrAMPM         As String
Dim StrTime         As String
Dim StrYear         As String
Dim StrMonthDay     As String
Dim StrMonth        As String
Dim StrDay          As String
Dim StrDate         As String
Dim StrDateTime     As String
Dim RegX            As Object
Set RegX = CreateObject("vbscript.regexp")
If Not Left(StrDateInput, 2) = "10" And _
Not Left(StrDateInput, 2) = "11" And _
Not Left(StrDateInput, 2) = "12" Then
StrDateInput = "0" & StrDateInput
End If
StrFullDate = Left(StrDateInput, 10)
If Right(StrFullDate, 1) = " " Then
StrFullDate = Left(StrDateInput, 9)
End If
StrFullTime = Replace(StrDateInput, StrFullDate & " ", "")
If Len(StrFullTime) = 10 Then
StrFullTime = "0" & StrFullTime
End If
StrAMPM = Right(StrFullTime, 2)
StrTime = StrAMPM & "-" & Left(StrFullTime, 8)
StrYear = Right(StrFullDate, 4)
StrMonthDay = Replace(StrFullDate, "/" & StrYear, "")
StrMonth = Left(StrMonthDay, 2)
StrDay = Right(StrMonthDay, Len(StrMonthDay) - 3)
If Len(StrDay) = 1 Then
StrDay = "0" & StrDay
End If
StrDate = StrYear & "-" & StrMonth & "-" & StrDay
StrDateTime = StrDate & "_" & StrTime
RegX.Pattern = "[\:\/\ ]"
RegX.IgnoreCase = True
RegX.Global = True
ArrangedDate = RegX.Replace(StrDateTime, "-")
ExitFunction:
Set RegX = Nothing
End Function
Sub GetFolder(Folders As Collection, EntryID As Collection, StoreID As Collection, Fld As  _
MAPIFolder)
Dim SubFolder       As MAPIFolder
Folders.Add Fld.FolderPath
EntryID.Add Fld.EntryID
StoreID.Add Fld.StoreID
For Each SubFolder In Fld.Folders
GetFolder Folders, EntryID, StoreID, SubFolder
Next SubFolder
ExitSub:
Set SubFolder = Nothing
End Sub
Function BrowseForFolder(Optional OpenAt As String) As String
Dim ShellApp As Object
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then
BrowseForFolder = ""
End If
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then
BrowseForFolder = ""
End If
Case Else
BrowseForFolder = ""
End Select
ExitFunction:
Set ShellApp = Nothing
End Function

Hi
du musst die Sub "PfadErstellen" in ein allgemeines Modul schreiben und dann
diesen Code:

If Not FSO.FolderExists(StrFolderPath) Then
FSO.CreateFolder (StrFolderPath)
End If

durch diesen ersetzen:

Call PfadErstellen(StrFolderPath)

die Prüfung, ob der Pfad schon vorhanden ist, ist nicht notwendig, denn dann läuft die Sub einfach durch.
allerdings sollte bei StrFolderPath kein "\" am Ende stehen.
oder du musst die Sub noch so eränzen:

Sub PfadErstellen(Pfad As String)
Dim PfadTeile
Dim Pfad1
Dim i As Long
PfadTeile = Split(Left(Pfad),Len(Pfad) - IIF(Right(Pfad, 1)="\",1,0)), "\")
Pfad1 = PfadTeile(0)

gruß Daniel

ich Depp!! Danke Daniel!!!!! Jetzt funkts.

Hi Daniel,
beim testen ist mitr gerad aufgefallen wenn man mehrere Unterordner hat siehts auf der Festplatte doch ziemlich wild aus.
C:\Posteingang\UnterornderA\UnterordnerB\UnterordnerC\etc
Wie müsste ich die deklaration im Pfad änder, so dass er wirklich nur den letzten UnterordnerC ohne den kompletten Pfad erstellt ?

Hi
ein Computerprogramm kann nicht hellsehen.
du musst immer genau die Ordnerstruktur angeben, die du auch haben willst.
wenn du den UnterordnerC haben willst, dann solltest du schon wissen, in welchem Übergeordneten Verzeichnis du den Ordner haben willst und wenn der UnterordnerC im UnterordnerA erscheinen soll, dann darfst du auch nur das angeben:
"C:\Posteingang\UnterornderA\UnterordnerC"
mein Programm erstellt immer genau die Ordnerstrukutr, die du vorgibst.
Gruß Daniel

Hi Daniel,
ja klar verstehe ich das schon,
Also gespeichert hat er den kompletten Pfad und legt diese an.
Das ist ja soweit auch genau richtig.
Was müsste man ändern damit er jetzt nur noch den letzten Ordner als Pfad nimmt ?
C:\unterordnerC
statt
C:\Posteingang\UnterornderA\UnterordnerB\UnterordnerC\etc
In dem eigentlich Code ist ChosenFolder deklariert, der genau nur diese Bezeichnung hat.
Wenn ich jedoch
StrFolderPath = StrFolder & "\"
durch
StrFolderPath = ChosenFolder & "\"
ersetze bekomme ich einen Fehler beim Zugriff auf Pfad/Datei und makiert bei MkDir Pfad1
MkDir Pfad1 zeigt aber eigentlich nur noch UnterordnerC korrekt an...

Hi
wenn du aus:
"C:\Posteingang\UnterornderA\UnterordnerB\UnterordnerC"
"C:\UnterordnerC"
machen willst dann:

Pfad1 = "C:\Posteingang\UnterornderA\UnterordnerB\UnterordnerC"
Pfad2 = Left(Pfad1, 2) & Right(Pfad1, InstrRev(Pfad1, "\"))

dann wird aber der UnterornderC direkt ins RootVerzeichnis gestellt.
Gruß Daniel