|
Hallo liebe VBA-Experten,
für die Mailablage in Outlook habe ich aus älteren VBA-Scripts eins zusammengestrickt, das in Outlook 2010 funktioniert. Mit folgender Ausnahme: ich möchte sowohl empfangene als auch gesendete Mails mit dem Sender- oder Empfängername ablegen. LKeider schließen sich beide gegenseitig aus. Wenn ich die fett markierte Zeile still lege kann ich immerhin Sendername ablegen. Wenn die Zeile aktiv bleibt, wird weder Sender noch Empfänger abgelegt. Über jede Unterstützung würde ich mich freuen.
Public Sub SaveMessageAsMsg()
Dim xMail As Outlook.MailItem
Dim xObjItem As Object
Dim xPath As String
Dim xDtDate As Date
Dim xDtDateSent As Date
Dim xName, xFileName As String
Dim xSender As String
Dim xRecipient As String
Dim Clean_Sonderzeichen As String
Dim i As Integer
On Error Resume Next
Set xShell = CreateObject("Shell.Application")
Set xFolder = xShell.BrowseForFolder(0, "Select a folder:", 0, strStartingFolder)
If Not TypeName(xFolder) = "Nothing" Then
Set xFolderItem = xFolder.self
xFileName = xFolderItem.path & "\"
Else
xFileName = ""
Exit Sub
End If
For Each xObjItem In Outlook.ActiveExplorer.Selection
If xObjItem.Class = olMail Then
Set xMail = xObjItem
xSender = xMail.SenderNAme
xRecipient = xMail.RecipientName
Clean_Sonderzeichen = xMail.Subject
Const strSonderzeichen As String = "-.,:;#+ß'*?=)(/&%$§!~\}][{|"
For i = 1 To Len(strSonderzeichen)
xMail.Subject = Replace(xMail.Subject, Mid(strSonderzeichen, i, 1), "")
Next i
xDtDate = xMail.ReceivedTime
xName = Format(xDtDate, "yymmdd" & "_", vbUseSystemDayOfWeek, _
vbUseSystem) & xMail.Subject & "_" & xSender & ".msg"
'xPath = xFileName + xName
'xMail.SaveAs xPath, olMSG
'End If
'If xObjItem.Class = olMail Then
'Set xMail = xObjItem
xRecipient = SentMail.RecipientName
'xName = xMail.Subject
'Clean_Sonderzeichen = xMail.Subject
xDtDateSent = xMail.SentOn
xName = Format(xDtDateSent, "yymmdd" & "_", vbUseSystemDayOfWeek, _
vbUseSystem) & xMail.Subject & "_" & xRecipient & ".msg"
xPath = xFileName + xName
xMail.SaveAs xPath, olMSG
End If
'Kategorie_setzen_Mail()
Dim olExplorer As Explorer
Dim olFolder As MAPIFolder
Dim olSelection As Selection
Set olExplorer = Application.ActiveExplorer
Set olFolder = Application.ActiveExplorer.CurrentFolder
Set olSelection = olExplorer.Selection
If olFolder.DefaultItemType = olMailItem Then
If olSelection.Count = 0 Then GoTo weiter
For x = 1 + x To olSelection.Count
With olSelection.item(x)
.Categories = "Abgelegt"
.ShowCategoriesDialog
.Save
End With
Next x
Else
weiter:
End If
Next
End Sub
|