Option Explicit
' DLL-Deklaration zum Feststellen des Usernames
Private Declare Function GetUserName Lib "advapi32.dll" Alias _
"GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
' DLL-Deklaration zum Erstellen aller erforderlichen Ordner mit Unterordnern
Private Declare Function MakePath Lib "imagehlp.dll" _
Alias "MakeSureDirectoryPathExists" _
(ByVal lpPath As String) As Long

Public Sub CommandButton1_Click()
Dim beleg$
Dim Result As Long
Dim sPath$
' Ordner mit Unterordner werden erstellt
beleg = "Angebot" ' Dient als Ersatz für die ComboBox. Das soll das 
' Auswahlkriterium sein
sPath = "G:\edv-service\mail_backup\"
Result = MakePath(strNewFolder(sPath$, beleg$))
Email_To_HDD strNewFolder(sPath$, beleg$)
End Sub

' Hier wird der Netzname ermittelt (wird ein Unterordner)
Private Function netuser()
Dim s As String
Dim cnt As Long
Dim ret As Long
Dim pos%
cnt = 199
s = String$(200, 0)
ret = GetUserName(s, cnt)
If ret <> 0 Then
netuser = Trim(Left$(s, cnt))
pos = InStr(netuser, Chr$(0))
If pos > 0 Then
netuser = Left$(netuser, pos - 1)
Else
netuser = netuser
End If
Else
netuser = ""
End If
End Function

' Mit folgender Funktion erstelle ich alle Ordner mit Unterordner
' auf einmal und baue gleich das Datum und die Uhrzeit mit ein.
' So werden für den User Zeitlich abgegrenzte Ordner erstellt :-)
Private Function strNewFolder(sPath$, beleg$) As String
strNewFolder = "G:\edv-service\mail_backup\" & beleg & "\" & netuser & "\" & _
  Format(Date, "yyyymmdd") _
& "." & Format(Time, "hhmmss") & "\"
End Function

Public Sub Email_To_HDD(ByVal strNewFolder As String)
Dim oOutlook As Object ' Outlook Object
Dim oNamespace As Object ' Namespace Object
Dim oFolder As Object ' MapiFolder Object
Dim oMail As Object ' Mail Object
Dim oAnhang As Object ' Attachment Object
Dim i As Integer
Dim j As Integer
Dim beleg$
Dim sPath$
 
' Outlook-Konstanten
Const olFolderInbox = 6
Const olTXT = 0
 
' Outlook-Objekt erstellen
Set oOutlook = CreateObject("Outlook.Application")
 
' Namespace: MAPI
Set oNamespace = oOutlook.GetNamespace("MAPI")
 
' Outlook-Ordner: "Neue Nachrichten"
Set oFolder = oNamespace.GetDefaultFolder(olFolderInbox)
 
' Alle Mails durchlaufen
i = 1
j = oFolder.Items.Count
Do While j > 0
Set oMail = oFolder.Items(j)
 
' Auf Anhang prüfen und evtl. speichern
With oMail.Attachments
i = .Count
Do While (i > 0)
Set oAnhang = .Item(i)
 
' Anhang unter entsprechendem Namen speichern.
' Das "i_" ist nur zur Sicherheit, um doppelte
' Dateinamen zu verhindern
oAnhang.SaveAsFile strNewFolder & CStr(i) & "_" & _
oAnhang.DisplayName
i = i - 1
Loop
End With
' An dieser Stelle erhalte ich einen Fehler (Interner Anwendungsfehler)
' Nachricht speichern
oMail.SaveAs strNewFolder & CStr(i) & "_" & _
oMail.Subject & ".txt", olTXT
' weiss nicht warum 
j = j - 1
Loop
 
' Fertig
MsgBox "Done"
 
' Objekte zerstören
Set oMail = Nothing
Set oAnhang = Nothing
Set oFolder = Nothing
Set oNamespace = Nothing
Set oOutlook = Nothing
End Sub