3
Outlook 2003 - Anhänge neuer Mails per VBA automatisch speichern
Hallo,
ich habe hier einen kleinen Code, welcher bewirkt, dass Anhänge neuer eingehender Mails automatisch in einem (neu angelegtem) Ordner gespeichert werden.
Unter Outlook 2000 funktioniert dies auch, unter 2003 aber nicht. Der Unterordner wird zwar beim Eintreffen einer neuen Mail mit Anhang angelegt, der Anhang aber nicht darin gespeichert. Was muss ich da noch verändern?
Torsten
ich habe hier einen kleinen Code, welcher bewirkt, dass Anhänge neuer eingehender Mails automatisch in einem (neu angelegtem) Ordner gespeichert werden.
Unter Outlook 2000 funktioniert dies auch, unter 2003 aber nicht. Der Unterordner wird zwar beim Eintreffen einer neuen Mail mit Anhang angelegt, der Anhang aber nicht darin gespeichert. Was muss ich da noch verändern?
Private Sub Application_NewMail()
Dim strNewFolder As String
Dim objPosteingang As MAPIFolder
Dim objNewMail As MailItem
On Error Resume Next
strNewFolder = "C:\Outlook-Anhang\" & Format(Date, "yyyy-mm-dd")
MkDir strNewFolder
Set objPosteingang = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
For Each objNewMail In objPosteingang.Items
With objNewMail
If .UnRead = True Then
intAnlagen = .Attachments.Count
If intAnlagen > 0 Then
For i = 1 To intAnlagen
.Attachments.Item(i).SaveAsFile strNewFolder & "\" & .Attachments.Item(i).FileName
Next i
End If
End If
End With
Next objNewMail
End SubTorsten
Share on Facebook
Share on Twitter
Share on Reddit
Share on LinkedinPlease also mark the comments that contributed to the solution of the article
Content-Key: 133877
Url: https://administrator.de/contentid/133877
Printed on: April 19, 2024 at 21:04 o'clock
3 Comments
Latest comment
Hi,
lass mal das On Error Resume Next weg, dann siehst Du die Fehler, die während der Laufzeit auftreten. Outlook 2003 hatte bei mir Probleme mit dem an den Ordner angehängen Datum und dem MkDir, prüf die zwei Zeilen nochmal .. Bei mir läuft das Script so:
Sub Application_NewMail()
Dim strNewFolder As String
Dim objPosteingang As MAPIFolder
Dim objNewMail As MailItem
' Prüfe, ob der Ordner bereits existiert
strNewFolder = "C:\Outlook-Anhang\"
' Target --> Posteingang
Set objPosteingang = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
' Wenn neue Mails ankommen, dann enthaltene Anlagen in strNewFolder speichern
For Each objNewMail In objPosteingang.Items
With objNewMail
If .UnRead = True Then
intAnlagen = .Attachments.Count
If intAnlagen > 0 Then
For i = 1 To intAnlagen
.Attachments.Item(i).SaveAsFile strNewFolder & "\" & .Attachments.Item(i).FileName
Next i
End If
End If
End With
Next objNewMail
End Sub
lass mal das On Error Resume Next weg, dann siehst Du die Fehler, die während der Laufzeit auftreten. Outlook 2003 hatte bei mir Probleme mit dem an den Ordner angehängen Datum und dem MkDir, prüf die zwei Zeilen nochmal .. Bei mir läuft das Script so:
Sub Application_NewMail()
Dim strNewFolder As String
Dim objPosteingang As MAPIFolder
Dim objNewMail As MailItem
' Prüfe, ob der Ordner bereits existiert
strNewFolder = "C:\Outlook-Anhang\"
' Target --> Posteingang
Set objPosteingang = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
' Wenn neue Mails ankommen, dann enthaltene Anlagen in strNewFolder speichern
For Each objNewMail In objPosteingang.Items
With objNewMail
If .UnRead = True Then
intAnlagen = .Attachments.Count
If intAnlagen > 0 Then
For i = 1 To intAnlagen
.Attachments.Item(i).SaveAsFile strNewFolder & "\" & .Attachments.Item(i).FileName
Next i
End If
End If
End With
Next objNewMail
End Sub
Hi fritzo,
bei mir speichert Outlook die Anhänge aber leider nicht ab. Es kommt der Fehler: "Laufzeitfehler '13': Typen unverträglich.". Der Debugger verweist dann auf "Next objNewMail" am Ende.
Torsten
Ach übrigens, wenn ich mit "Set objPosteingang = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)" den Posteingang angeben kann ist es doch sicherlich auch möglich einen darunter selbst angelegten Ordner anzugeben, oder?
bei mir speichert Outlook die Anhänge aber leider nicht ab. Es kommt der Fehler: "Laufzeitfehler '13': Typen unverträglich.". Der Debugger verweist dann auf "Next objNewMail" am Ende.
Torsten
Ach übrigens, wenn ich mit "Set objPosteingang = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)" den Posteingang angeben kann ist es doch sicherlich auch möglich einen darunter selbst angelegten Ordner anzugeben, oder?
Hallo,
probier das mal so:
Für einen selbst angelegten Ordner probier bitte mal das hier:
Gruß,
fritzo
probier das mal so:
Private Sub Application_NewMail()
Dim fso As Object
Dim objPosteingang As MAPIFolder
Dim objNewMail As MailItem
Dim strNewFolder As String
Dim intAnlagen As Integer
Dim i As Integer
Dim FolderPath As String
Dim DateFolderPath As String
Set objPosteingang = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
FolderPath = "C:\Outlook-Anhang\"
DateFolderPath = FolderPath & "\" & Format(Date, "yyyy-mm-dd")
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(FolderPath) Then
fso.CreateFolder FolderPath
End If
If Not fso.FolderExists(DateFolderPath) Then
fso.CreateFolder DateFolderPath
End If
For Each objNewMail In objPosteingang.Items
With objNewMail
If .UnRead = True Then
intAnlagen = .Attachments.Count
If intAnlagen > 0 Then
For i = 1 To intAnlagen
If Not fso.FileExists(DateFolderPath & "\" & .Attachments.Item(i).FileName) Then
.Attachments.Item(i).SaveAsFile DateFolderPath & "\" & .Attachments.Item(i).FileName
End If
Next i
End If
End If
End With
Next objNewMail
Set fso = Nothing
End SubFür einen selbst angelegten Ordner probier bitte mal das hier:
Set objPosteingang = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders.Item("Unterordner) Gruß,
fritzo
