Hallo zusammen,

ich bin keine VB Kennerin, habe mir die letzten Monate mit den verschiedensten Makroschnipslen aus dem Inet meine Arbeit im Büro vereinfacht.

Ich habe ein Makro, welches in Outlook Emails im Hintergrund in Word öffnet und als pdf abspeichert, das habe ich an meine Bedürfnisse angepasst und es läuft super. Ich habe Office 2013. Jetzt soll meine Kollegin das ganze übernehmen und sie hat Office 2016 und das Makro bleibt an einer bestimmten Stelle stehen. Ebenfalls hängt sich Word dabei auf. Es liegt also am öffnen von Word 2016.

Nur da hört mein Wissen dann auf. Vielleicht weiss einer von euch wieso das jetzt hakt? Herzlichen Dank.

Set wrdDoc = wrdApp.Documents.Open(FileName:=tmpFileName, Visible:=True)

Sub Savetopdf()
    Dim Selection As Selection
    Dim obj As Object
    Dim Item As MailItem
 
    Dim wrdApp As Word.Application
    Dim wrdDoc As Word.Document
    Set wrdApp = CreateObject("Word.Application")
    Set Selection = Application.ActiveExplorer.Selection

For Each obj In Selection
 
    Set Item = obj
    
    Dim fso As Object, TmpFolder As Object
    Dim sName As String
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set tmpFileName = fso.GetSpecialFolder(2)
    
    sName = Item.Subject
    ReplaceCharsForFileName sName, "-"
    tmpFileName = tmpFileName & "\" & sName & ".mht"
    
    Item.SaveAs tmpFileName, olMHTML
    
Set wrdDoc = wrdApp.Documents.Open(FileName:=tmpFileName, Visible:=True)
  
    Dim WshShell As Object
    Dim SpecialPath As String
    Dim strToSaveAs As String
    Set WshShell = CreateObject("WScript.Shell")
    MyDocs = "\\Pfad"
    
strToSaveAs = MyDocs & "\" & sName & ".pdf"
 
' check for duplicate filenames
' if matched, add the current time to the file name
If fso.FileExists(strToSaveAs) Then
   sName = sName & Format(Now, "hhmmss")
   strToSaveAs = MyDocs & "\" & sName & ".pdf"

End If

wrdApp.ActiveDocument.ExportAsFixedFormat OutputFileName:= _
    strToSaveAs, 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

Set dlgSaveAs = Nothing

Next obj
    wrdDoc.Close
    wrdApp.Quit True
    Set wrdDoc = Nothing
    Set wrdApp = Nothing
    Set WshShell = Nothing
    Set obj = Nothing
    Set Selection = Nothing
    Set Item = Nothing
    
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