Sub SaveAsPDFfile()

'UpdatebyExtendoffice

Dim MyOlNamespace As NameSpace

Dim MySelectedItem As MailItem

Dim Response As String

Dim FSO As Object, TmpFolder As Object

Dim tmpFileName As String

Dim wrdApp As Object

Dim wrdDoc As Object

Dim bStarted As Boolean

Dim dlgSaveAs As FileDialog

Dim fdfs As FileDialogFilters

Dim fdf As FileDialogFilter

Dim i As Integer

Dim WshShell As Object

Dim SpecialPath As String

Dim msgFileName As String

Dim strCurrentFile As String

Dim strName As String

Dim oRegEx As Object

Dim intPos As Long

Set MyOlNamespace = Application.GetNamespace("MAPI")

Set MySelectedItem = ActiveExplorer.Selection.Item(1)

Set FSO = CreateObject("Scripting.FileSystemObject")

tmpFileName = FSO.GetSpecialFolder(2)

strName = "email_temp.mht"

tmpFileName = tmpFileName & "\" & strName

MySelectedItem.SaveAs tmpFileName, 10

On Error Resume Next

Set wrdApp = GetObject(, "Word.Application")

If Err Then

Set wrdApp = CreateObject("Word.Application")

bStarted = True

End If

On Error GoTo 0

Set wrdDoc = wrdApp.Documents.Open(FileName:=tmpFileName, Visible:=False, Format:=7)

Set dlgSaveAs = wrdApp.FileDialog(msoFileDialogSaveAs)

Set fdfs = dlgSaveAs.Filters

i = 0

For Each fdf In fdfs

i = i + 1

If InStr(1, fdf.Extensions, "pdf", vbTextCompare) > 0 Then

Exit For

End If

Next fdf

dlgSaveAs.FilterIndex = i

Set WshShell = CreateObject("WScript.Shell")

SpecialPath = WshShell.SpecialFolders(16)

msgFileName = MySelectedItem.Subject

Set oRegEx = CreateObject("vbscript.regexp")

oRegEx.Global = True

oRegEx.Pattern = "[\/:*?""<>|]"

msgFileName = Trim(oRegEx.Replace(msgFileName, ""))

dlgSaveAs.InitialFileName = SpecialPath & "\" & msgFileName

If dlgSaveAs.Show = -1 Then

strCurrentFile = dlgSaveAs.SelectedItems(1)

If Right(strCurrentFile, 4) <> ".pdf" Then

Response = MsgBox("Sorry, only saving in the pdf-format is supported." & _

vbNewLine & vbNewLine & "Save as pdf instead?", vbInformation + vbOKCancel)

If Response = vbCancel Then

wrdDoc.Close 0

If bStarted Then wrdApp.Quit

Exit Sub

ElseIf Response = vbOK Then

intPos = InStrRev(strCurrentFile, ".")

If intPos > 0 Then

strCurrentFile = Left(strCurrentFile, intPos - 1)

End If

strCurrentFile = strCurrentFile & ".pdf"

End If

End If

wrdApp.ActiveDocument.ExportAsFixedFormat OutputFileName:= _

strCurrentFile, _

ExportFormat:=17, _

OpenAfterExport:=False, _

OptimizeFor:=0, _

Range:=0, _

From:=0, _

To:=0, _

Item:=0, _

IncludeDocProps:=True, _

KeepIRM:=True, _

CreateBookmarks:=0, _

DocStructureTags:=True, _

BitmapMissingFonts:=True, _

UseISO19005_1:=False

End If

Set dlgSaveAs = Nothing

wrdDoc.Close

If bStarted Then wrdApp.Quit

Set MyOlNamespace = Nothing

Set MySelectedItem = Nothing

Set wrdDoc = Nothing

Set wrdApp = Nothing

Set oRegEx = Nothing

End Sub