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
|