Private Sub SaveOnCDrive_JJJJ()
Dim myOlApp As New Outlook.Application
Dim myItem As Outlook.Inspector
Dim objItem As Object
Dim Pfad, DatNam, Empf, Absend, Betr, EDat, ETime, EPfad As String
Dim SaveOK As Boolean
Dim EmpfDat As Date
Dim Kat As String
Set myItem = myOlApp.ActiveInspector
Pfad = "C:\E-Mail-Archiv\"
If Not TypeName(myItem) = "Nothing" Then
Set objItem = myItem.CurrentItem
Empf = Left(objItem.To, 25)
Betr = Left(objItem.Subject, 30)
If InStr(objItem.SenderEmailAddress, "@") = 0 Then
Absend = objItem.SenderName
Else
Absend = objItem.SenderEmailAddress
End If
Call SonderzeichenErsetzen(Empf)
Call SonderzeichenErsetzen(Betr)
Call SonderzeichenErsetzen(Absend)
Kat = objItem.Categories
If InStr(1, Kat, "abgelegt") = 0 Then
objItem.Categories = Kat & "; abgelegt"
objItem.Save
End If
EmpfDat = objItem.ReceivedTime
EDat = Year(EmpfDat) & "-" & Right("0" & Month(EmpfDat), 2) & "-" & Right("0" & Day(EmpfDat), 2)
EPfad = Pfad & Year(EmpfDat) & "\"
ETime = Right("0" & Hour(EmpfDat), 2) & Right("0" & Minute(EmpfDat), 2)
DatNam = EDat & "_" & ETime & "__" & Absend & "__" & Betr & "__An_" & Empf
SaveOK = objItem.SaveAs(EPfad & DatNam & ".msg", olMSG)
Else
MsgBox "There is no current active inspector."
End If
End Sub
Sub Ordnerablage_JJJJ_starten()
Dim SO_Name As Variant
Dim SO_AnzahlMails, SO_Abgelegt As Integer
Set SO_olApp = Outlook.Application
Set SO_Folder = Outlook.Application.Session.Folders.Item("E-Mail-Adresse").Folders.Item("Ablage_Sammelordner")
Set SO_Mail = SO_Folder.Items
SO_AnzahlMails = SO_Mail.Count
SO_Abgelegt = 0
MsgBox (SO_AnzahlMails & " Mails sind im Ordner vorhanden.")
For Each SO_Item In SO_Mail
SO_Item.Display
Call SaveOnCDrive_JJJJ
SO_Item.Save
SO_Abgelegt = SO_Abgelegt + 1
SO_Item.Close olSave
Next
MsgBox ("Es wurden " & SO_Abgelegt & " Mails abgelegt")
End Sub
Sub SonderzeichenErsetzen(Text)
Text = Replace(Text, "\", "{")
Text = Replace(Text, "/", "{")
Text = Replace(Text, ":", ";")
Text = Replace(Text, "*", "+")
Text = Replace(Text, "?", "¿")
Text = Replace(Text, """", "'")
Text = Replace(Text, "<", "[")
Text = Replace(Text, ">", "]")
Text = Replace(Text, "|", "{")
End Sub