Option Explicit
'12.04.2019 Günter Sommer (neue, überarbeitete Version Februar 2020)
Public Nachricht As MailItem

Sub MarkierteEingangsMailSpeichern()
'12.04.2019 Günter Sommer (12.02.2020 überarbeitet Dialog-Objekt von Excel verwendet im Unterprogramm)
'Eingangs-email speichern
Dim Ausblick As Application, Postamt As NameSpace
Dim DieExplorer As Outlook.Explorers, DerExplorer As Outlook.Explorer
Dim DieOrdner As Folders, DerOrdner As Folder
Dim ii As Long, zk As String, Absender As String, Empfangszeit As String, Betreff As String
Dim DateiName As String ' Name unter dem die mail gespeichert werden soll. (kompletter Name mit Pfad)
Dim Pfad As String

Set Ausblick = Outlook.Application
Set DerExplorer = Ausblick.ActiveExplorer

If DerExplorer.Selection.Count > 1 Then
  MsgBox "Es ist mehr als ein Element im aktiven Forscher markiert. Das geht nicht. Korrigieren Sie das."
End If
If DerExplorer.Selection.Count = 1 Then ' 1 Element ist markiert
  If DerExplorer.Selection.Item(1).Class = olMail Then 'Das selektierte Element ist eine email
    Set Nachricht = DerExplorer.Selection.Item(1)
    Absender = "E_" & "'" & Nachricht.Sender.Name & "(" & UnerlaubteZeichenEntfernen(Nachricht.SenderEmailAddress) & ")"
    Empfangszeit = UnerlaubteZeichenEntfernen(Nachricht.ReceivedTime)
    Betreff = UnerlaubteZeichenEntfernen(Nachricht.Subject)
    
    Pfad = Pfadname
    If Pfad = "Abbruch" Then
      MsgBox "Die Auswahl des Zielpfades wurde abgebrochen. Alo ist Sense!!!"
      Exit Sub
    End If

    If Mid(Pfad, Len(Pfad), 1) = "\" Then 'wenn die Nachricht in einem Wurzelverzeichnis abgelegt werden soll
       zk = Pfad & Absender & Empfangszeit & " " & Betreff
    Else
       zk = Pfad & "\" & Absender & Empfangszeit & " " & Betreff
    End If
    Nachricht.SaveAs zk & " .msg", OlSaveAsType.olMSG
  End If
End If
End Sub
Sub MarkierteAusgangsMailSpeichern()
'12.04.2019 Günter Sommer (12.02.2020 überarbeitet Dialog-Objekt von Excel verwendet im Unterprogramm)
'Eingangs-email speichern
Dim Ausblick As Application, Postamt As NameSpace
Dim DieExplorer As Outlook.Explorers, DerExplorer As Outlook.Explorer
Dim DieOrdner As Folders, DerOrdner As Folder
Dim ii As Long, zk As String, Empfänger As String, Sendezeit As String, Betreff As String
Dim DateiName As String, Pfad As String

Set Ausblick = Outlook.Application
Set DerExplorer = Ausblick.ActiveExplorer

If DerExplorer.Selection.Count > 1 Then
  MsgBox "Es ist mehr als ein Element im aktiven Forscher markiert. Das geht nicht. Korrigieren Sie das."
End If
If DerExplorer.Selection.Count = 1 Then ' 1 Element ist markiert
  If DerExplorer.Selection.Item(1).Class = olMail Then 'Das selektierte Element ist eine email
    Set Nachricht = DerExplorer.Selection.Item(1)
    Empfänger = "A_" & "'" & Nachricht.Sender.Name & "'" & "(" & UnerlaubteZeichenEntfernen(Nachricht.To) & ")"
    Sendezeit = UnerlaubteZeichenEntfernen(Nachricht.ReceivedTime)
    Betreff = UnerlaubteZeichenEntfernen(Nachricht.Subject)
    
    Pfad = Pfadname
    If Pfad = "Abbruch" Then
      MsgBox "Die Auswahl des Zielpfades wurde abgebrochen. Alo ist Sense!!!"
      Exit Sub
    End If

    If Mid(Pfad, Len(Pfad), 1) = "\" Then 'wenn die Nachricht in einem Wurzelverzeichnis abgelegt werden soll
       zk = Pfad & Empfänger & Sendezeit & " " & Betreff
    Else
       zk = Pfad & "\" & Empfänger & Sendezeit & " " & Betreff
    End If

    Nachricht.SaveAs zk & " .msg", OlSaveAsType.olMSG
  End If
End If
End Sub
'-------------------------- Funktionen ---------------
Private Function UnerlaubteZeichenEntfernen(ByVal zk As String) As String
'entfernt aus dem übergebenen String diejenigen Zeichen, die in Dateinamen nicht vorkommen dürfen
Dim ii As Long 

 UnerlaubteZeichenEntfernen = Replace(zk, ":", "#", 1, Len(zk), vbTextCompare)
 UnerlaubteZeichenEntfernen = Replace(UnerlaubteZeichenEntfernen, "/", " ", 1, Len(UnerlaubteZeichenEntfernen), vbTextCompare)
 UnerlaubteZeichenEntfernen = Replace(UnerlaubteZeichenEntfernen, "\", " ", 1, Len(UnerlaubteZeichenEntfernen), vbTextCompare)
 UnerlaubteZeichenEntfernen = Replace(UnerlaubteZeichenEntfernen, "?", " ", 1, Len(UnerlaubteZeichenEntfernen), vbTextCompare)
 'Return
End Function
Public Function Pfadname() As String
Dim EKSL As Excel.Application
Dim Ergebnisse As Variant ' muß Variant sein
Set EKSL = New Excel.Application 'Excel als Hilfsapplication starten, da die Outlook-Anwendung kein FileDialog-Object besitzt.
'EKSL.Application.FileDialog(msoFileDialogFolderPicker).Show
With EKSL.Application.FileDialog(msoFileDialogFolderPicker)
  If .Show = -1 Then 'Taste OK wurde gedrückt
    Pfadname = .SelectedItems(1)
  Else
    'MsgBox .Show 'Abbruch gedrückt gibt das Ergebnis 0
    Pfadname = "Abbruch"
  End If
End With
Set EKSL = Nothing
End Function