Hallo Reinhard,
vielen Dank schonmal für die angebotene Hilfe. Ich habe mich gleich ans googeln gemacht und etwas gefnunden, bei dem ich hoffe, dass es dir hilft. Meinetwegen können die Mails auch gleich beim Empfang geprüft werden und das was übrig bleibt wird über eine Regel verschoben, dann muss der Code nur auf den Eingang reagieren, nicht unbedingt auf Mails in einem bestimmten Ordner.
Dennoch habe ich etwas gefunden, wo ich denke, dass es evtl. passt.
- Code, der auf Mail in Mailordner reagiert:
Private Sub Application_NewMail()
Dim Foldername As String
Dim Foldername1 As String
Dim objIn As MAPIFolder
Dim objNewMail As MailItem
On Error Resume Next
Set objIn = Application.GetNamespace(„MAPI“).GetDefaultFolder(olFolderInbox)
For Each objNewMail In objIn.Items
v = .Attachments.Item(1).FileName
If Left(v, 8) = „Rechnung“ Then
If objNewMail.UnRead = True Then
NumberOfMails = .Attachments.Count
If NumberOfMails > 0 Then
’ create the folder c:\temp and in this folder a folder with the name of the mail subject
’ Existing folders won’t be over overwritten, objNewMail.Subject is not case sensitive
Folder2009 = „C:\Dokumente und Einstellungen\Rechnung\2009“
Folder2010 = „C:\Dokumente und Einstellungen\Rechnung\2010“
Folder2011 = „C:\Dokumente und Einstellungen\Rechnung\2011“
For i = 1 To NumberOfMails
’ save the attachment to the folder mentioned
’ above and replace the filname with the mail-body
’ the vbCrLf, „“ function replaces vertical spacing
’ pdf is the filetype of the scanned paper
u = .Attachments.Item(i).FileName
If Left(u, 13) = „Rechnung_2009“ Then
.Attachments.Item(i).SaveAsFile (Folder2009) & „“ & .Attachments.Item(i).FileName
End If
If Left(u, 13) = „Rechnung_2010“ Then
.Attachments.Item(i).SaveAsFile (Folder2010) & „“ & .Attachments.Item(i).FileName
End If
If Left(u, 13) = „Rechnung_2011“ Then
.Attachments.Item(i).SaveAsFile (Folder2011) & „“ & .Attachments.Item(i).FileName
End If
objNewMail.UnRead = False
Next i
End If
End If
End If
End With
Next objNewMail
End Sub
- Code, der den Anhang öffnet:
Sub AnhaengeOeffnen()
Dim myS As Object
Dim myIt As Outlook.MailItem
Dim myAt As Outlook.Attachments
Dim i As Long
Dim att As String
On Error Resume Next
Select Case TypeName(Application.ActiveWindow)
Case „Explorer“
Set myIt = ActiveExplorer.Selection.Item(1)
Case „Inspector“
Set myIt = ActiveInspector.CurrentItem
Case Else
End Select
On Error GoTo 0
If myIt Is Nothing Then
GoTo ExitProc
End If
Set myAt = MyIt.Attachments
’ Windows Script Host Object
Set myS = CreateObject(„WScript.Shell“)
If myAt.Count > 0 Then
For i = 1 To myAt.Count
att = myAt.Item(i).DisplayName
On Error Resume Next
Kill „C:“ & att
On Error GoTo 0
myAt.Item(i).SaveAsFile „C:“ & att
myS.Run „C:“ & att
Next i
End If
ExitProc:
Set myAt = Nothing
Set myIt = Nothing
Set myS = Nothing
End Sub
- Code, der eine Mail endgültig löscht:
Sub DeleteSelectedMailItem() Dim olMailSel As MailItem Select Case TypeName(Application.ActiveWindow) Case „Explorer“ ’ Set olMailSel = _ Application.ActiveExplorer.Selection.Item(1) Case „Inspector“ Set olMailSel = Application.ActiveInspector.CurrentItem Case Else 'kann eigentlich nicht sein, aber wer weiß… End Select If Not olMailSel Is Nothing Then olMailSel.Delete End If Set olMailSel = NothingEnd Sub
Ich hoffe damit kann man etwas anfangen. Falls du die Angaben benötigst, welche Wörter im Betreff abgefragt werden über die Regel und wie der Titel des Anhangs lautet, sag mir bitte Bescheid, dann schick ich dir eine Mail. Ich möchte die Begriffe ungern hier veröffentlichen, da einige Leser sonst wissen, in welcher Branche ich arbeite. Ich möchte lieber so anonym bleiben wie möglich. Danke für das Verständnis.
Nochmals vielen Dank für die Mühe.
Gruß
Imhotep
