Hallo habe mir folgendes Makro gebastelt. Ich bekomme es aber absolut nicht hin das die gesendeten Mails nur im Ordner Diagnosen und die eingehenden Mails nur im Ordner Patientendaten gespeichert werden. er speichert beim Senden und empfangen immer in beide Ordner. Kann mir da bitte jemand helfen???
Gruß René
Private Sub Application_NewMailEx _
(ByVal EntryIDCollection As String)
Dim arr() As String
Dim i As Integer
Dim ns As Outlook.NameSpace
Dim itm As MailItem
Dim m As Outlook.MailItem
Dim MyBetreff As String
On Error Resume Next
Set ns = Application.Session
arr = Split(EntryIDCollection, ",")
'Mailausgang durchsuchen
MyBetreff = "Epikrise"
For i = 0 To UBound(arr)
Set itm = ns.GetItemFromID(arr(i))
If itm.Class = olMail Then
Set m = itm
Set myItem = Application.Session.GetDefaultFolder(olFolderSentItem).Items(1)
myItem.Display
strname = m.Subject
If InStr(1, strname, MyBetreff) = 0 Then
myItem.Close olSave
myItem.UnRead = True
Exit Sub
ElseIf InStr(1, strname, MyBetreff) <> 0 Then
strname = Replace(strname, ":", " ")
strname = Replace(strname, "/", " ")
End If
Dim strPrompt As String
m.SaveAs "Y:\Diagnosen\" & strname & " " & "Datum" & "_" & Day(Date) & "_" _
& Month(Date) & "_" & Year(Date) & "_" & "Uhrzeit" & "_" & Hour(Time) & "_" _
& Minute(Time) & ".msg", olMSG
myItem.Close olSave
myItem.UnRead = True
End If
Next
'Posteingang durchsuchen
MyBetreff = "Epikrise"
For i = 0 To UBound(arr)
Set itm = ns.GetItemFromID(arr(i))
If itm.Class = olMail Then
Set m = itm
Set myItem = Application.Session.GetDefaultFolder(olFolderInbox).Items(1)
myItem.Display
strname = m.Subject
If InStr(1, strname, MyBetreff) = 0 Then
myItem.Close olSave
myItem.UnRead = True
Exit Sub
ElseIf InStr(1, strname, MyBetreff) <> 0 Then
strname = Replace(strname, ":", " ")
strname = Replace(strname, "/", " ")
End If
m.SaveAs "Y:\Patientendaten\" & strname & " " & "Datum" & "_" & Day(Date) & "_" _
& Month(Date) & "_" & Year(Date) & "_" & "Uhrzeit" & "_" & Hour(Time) & "_" _
& Minute(Time) & ".msg", olMSG
myItem.Close olSave
myItem.UnRead = True
End If
Next
Set ns = Nothing
Set itm = Nothing
Set m = Nothing
End Sub
|