Option Explicit
 
Private Sub Form_Load()
  ' Mails und Anlagen in den Ordner
  ' f:\HoRes8\Hotel\IFC\Internet speichern. Falls der Ordner nicht existiert,
  ' wird dieser autom. erstellt.
  Email_To_HDD "f:\IFC\Internet\"
End Sub
Public Sub Email_To_HDD(ByVal sPath 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
 
  ' Outlook-Konstanten
  Const olFolderInbox = 6
  Const olTXT = 0
 
  ' Ggf. abschließenden Backslash entfernen
  If Right$(sPath, 1) = "\" Then
    sPath = Left$(sPath, Len(sPath) - 1)
  End If
 
  ' Falls Zielordner nicht existiert,
  ' jetzt erstellen
  If Dir$(sPath, vbDirectory + vbHidden) = "" Then
    MkDir sPath
  End If
 
  ' 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 = i
  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 sPath & "\" & CStr(i) & "_" & _
          oAnhang.DisplayName & ".dat"
 
        i = i - 1
   '   Loop
    End With
 
     ' Nachricht speichern
    'oMail.SaveAs sPath & CStr(i) & "_"
 
    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
End Sub