'********************************************************************************
'*
'* Anwendung "EMailExportieren"
'*
'* Es sollen neben gescannten Papierdokumenten auch per E-Mail empfangene oder
'* gesendete Informationen abgelegt werden.
'* Dies erledigt das Makro "EmailExportieren". Es exportiert markierte E-Mails
'* mitsamt Anhängen in den Ordner "lw:\ordner\unterordner" (+ ggf. vom Anwender
'* adhoc benannter Unterordner).
'*
'*
'*
'*
'********************************************************************************
Option Explicit

Sub ControlBar()

    Dim sPath As String
    sPath = "lw:\ordner\!emails"

    Call SaveMessageAsPDF(sPath) ' Speichern als PDF
    'Call SaveMessageAsMsg ' alternativ: Speichern im msg-Format
    Beep
    'MsgBox "E-Mail wurde abgelegt", vbOKOnly, "xxxxxxxxxxxx"
        
    If MsgBox("E-Mail(s) wurde(n) abgelegt. Möchten Sie den Ordner öffnen?", vbYesNo, "eAkte") = vbYes Then
        Shell "explorer """ & sPath & "", vbNormalFocus
    End If


End Sub

Sub SaveMessageAsPDF(sPath)
     
    'Dim oXL As Excel.Application 'Early Binding
    'Set oXL = NEW Excel.Appplication 'Early Binding
    'Dim oXL As Object 'Late Binding
    'Set oXL = GetObject(, "Excel.Application") 'Late-Binding
     
    ' Word
    ' Late Binding
    Dim wrdApp As Object
    Dim wrdDoc As Object
    'neue Word-Instanz öffnen (ansonsten würde ein ggf. geöffnetes Dokument zerschossen)
    Set wrdApp = CreateObject("Word.Application")
    
    ' Outlook
    Dim olApp As Outlook.Application
    Dim olNs As Outlook.NameSpace
    Dim olFldr As Outlook.MAPIFolder
    'Dim olAtts As Outlook.Attachments
    'Dim olAtt As Outlook.Attachment
    Dim olMsg As Outlook.MailItem
    Dim olSelection As Selection
    
    ' Windows Scripting Host
    Dim wshShell As Object
    Dim SpecialPath As String
    Dim sToSaveAs As String
    Dim tmpFileName As String
    Set wshShell = CreateObject("WScript.Shell")
    
    ' File System Object
    Dim FSO As Object, TmpFolder As Object
    Dim sName As String
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    ' Lokale Variablen
    Dim iCtr As Long, iAttachCnt As Long
    Dim iMsgCount As Integer
    Dim sFileNames As String
    Dim tempPath As String
    Dim sDocId

    'get reference to inbox
    Set olApp = New Outlook.Application
    Set olNs = olApp.GetNamespace("MAPI")
    Set olFldr = olNs.GetDefaultFolder(olFolderInbox) ' ggf. anderen Ordner an-geben
    'Debug.Print "Total Items: "; olFldr.Items.Count
    'Debug.Print "Total Unread items = " & olFldr.UnReadItemCount
    Set olSelection = Application.ActiveExplorer.Selection
    
    tempPath = Environ("Temp")
    'Set tmpPath = FSO.GetSpecialFolder(2) ' alternativ

    For Each olMsg In olSelection
     
        'basic info about message
        'Debug.Print olMsg.To
        'Debug.Print olMsg.CC
        'Debug.Print olMsg.Subject
        'Debug.Print olMsg.Body
        
        sDocId = InputBox("Bitte Dokument-Identifikation angeben", "xxxxxxxxxxxxxx", "unbekannt")
        If Not (FSO.FolderExists(sPath & "\" & sDocId)) Then
            FSO.CreateFolder (sPath & "\" & sDocId)
        End If

        sName = olMsg.Subject
        ReplaceCharsForFileName sName, "_" ' Zeichen, die im Dateinamen icht er-laubt sind, ersetzen
        sName = Format(olMsg.ReceivedTime, "yyyy-mm-dd", vbUseSystemDayOfWeek, vbUseSystem) & Format(olMsg.ReceivedTime, "-hhnnss", vbUseSystemDayOfWeek, vbU-seSystem) & "-" & sName
        tmpFileName = tempPath & "\" & sName & "_" & Format(Now, "hhmmss") & ".mht"
        olMsg.SaveAs tmpFileName, olMHTML
        
        Set wrdDoc = wrdApp.Documents.Open(FileName:=tmpFileName)
        sToSaveAs = sPath & "\" & sDocId & "\" & sName & ".pdf"
        ' check for duplicate filenames. if matched, add the current time to the file name
        If FSO.FileExists(sToSaveAs) Then
            sName = sName & "_" & Format(Now, "hhmmss")
            sToSaveAs = sPath & "\" & sDocId & "\" & sName & ".pdf"
        End If
          
        wrdApp.ActiveDocument.ExportAsFixedFormat OutputFileName:= _
            sToSaveAs, ExportFormat:=wdExportFormatPDF, _
            OpenAfterExport:=False, OptimizeFor:=wdExportOptimizeForPrint, _
            Range:=wdExportAllDocument, From:=0, To:=0, Item:= _
            wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _
            CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
            BitmapMissingFonts:=True, UseISO19005_1:=False

        ' ggf. vorhandene Anhänge speichern
        'reference and save all attachments
        iAttachCnt = olMsg.Attachments.Count
        If iAttachCnt > 0 Then
            For iCtr = 1 To iAttachCnt
                olMsg.Attachments.Item(iCtr).SaveAsFile sPath & "\" & sDocId & "\" & olMsg.Attachments.Item(iCtr).FileName
            Next iCtr
        End If

    Next olMsg
    
    ' Clean up
    wrdDoc.Close
    wrdApp.Quit
    Set wrdDoc = Nothing
    Set wrdApp = Nothing
    Set wshShell = Nothing
 
End Sub
 
Sub SaveMessageAsMsg()
  
    Dim oMail As Outlook.MailItem
    Dim objItem As Object
    Dim sPath As String
    Dim dtDate As Date
    Dim sName As String
    Dim env As String
 
    env = CStr(Environ("USERPROFILE"))
    
    For Each objItem In ActiveExplorer.Selection
        If objItem.MessageClass = "IPM.Note" Then
            Set oMail = objItem
            sName = oMail.Subject
            ReplaceCharsForFileName sName, "-"
            dtDate = oMail.ReceivedTime
            sName = Format(dtDate, "yyyy-mm-dd", vbUseSystemDayOfWeek, vbUseSys-tem) & Format(dtDate, "-hhnnss", vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".msg"
            'sPath = env & "\Documents\"
            'sPath = "f:\temp\"
            'Debug.Print sPath & sName
            oMail.SaveAs sPath & sName, olMsg
        End If
    Next
  
End Sub

' This function removes invalid and other characters from file names
Private Sub ReplaceCharsForFileName(sName As String, sChr As String)
  
  sName = Replace(sName, "/", sChr)
  sName = Replace(sName, "\", sChr)
  sName = Replace(sName, ":", sChr)
  sName = Replace(sName, "?", sChr)
  sName = Replace(sName, Chr(34), sChr)
  sName = Replace(sName, "<", sChr)
  sName = Replace(sName, ">", sChr)
  sName = Replace(sName, "|", sChr)
  sName = Replace(sName, "&", sChr)
  sName = Replace(sName, "%", sChr)
  sName = Replace(sName, "*", sChr)
  sName = Replace(sName, " ", sChr)
  sName = Replace(sName, "{", sChr)
  sName = Replace(sName, "[", sChr)
  sName = Replace(sName, "]", sChr)
  sName = Replace(sName, "}", sChr)
  sName = Replace(sName, "!", sChr)

End Sub

Sub GetSpecialFolder()

    'Special folders are : AllUsersDesktop, AllUsersStartMenu, AllUsersPrograms, AllUsersStartup, Desktop,
    'Favorites, Fonts, MyDocuments, NetHood, PrintHood, Programs, Recent, SendTo, StartMenu, Startup, Templates
    'https://technet.microsoft.com/en-us/library/ee176604.aspx
     
    'Get Favorites folder and open it
    Dim wshShell As Object
    Dim SpecialPath As String

    Set wshShell = CreateObject("WScript.Shell")
    SpecialPath = wshShell.SpecialFolders("Favorites")
    MsgBox SpecialPath
    'Open folder in Explorer
    'Shell "explorer.exe " & SpecialPath, vbNormalFocus
    
    'Here are a few VBA path functiolNs
    MsgBox Application.Path
    MsgBox Application.DefaultFilePath
    MsgBox Application.TemplatesPath
    MsgBox Application.StartupPath
    MsgBox Application.UserLibraryPath
    MsgBox Application.LibraryPath
    
End Sub