Sub SaveAsPDFfile()
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")
'Make sure at least one item is selected
'Retrieve the selected item
Set MySelectedItem = ActiveExplorer.Selection.Item(1)
'Get the user's TempFolder to store the item in
Set FSO = CreateObject("Scripting.FileSystemObject")
tmpFileName = FSO.GetSpecialFolder(2)
'construct the filename for the temp mht-file
strName = "email_temp.mht"
tmpFileName = tmpFileName & "\" & strName
'Save the mht-file
MySelectedItem.SaveAs tmpFileName, 10
'Create a Word object
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
'Open the mht-file in Word without Word visible
Set wrdDoc = wrdApp.Documents.Open(FileName:=tmpFileName, Visible:=False, Format:=7)
'Define the SafeAs dialog
Set dlgSaveAs = wrdApp.FileDialog(msoFileDialogSaveAs)
'Determine the FilterIndex for saving as a pdf-file
'Get all the filters
Set fdfs = dlgSaveAs.Filters
'Loop through the Filters and exit when "pdf" is found
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
'Set the FilterIndex to pdf-files
dlgSaveAs.FilterIndex = i
'Get location of My Documents folder
Set WshShell = CreateObject("WScript.Shell")
SpecialPath = "D:\MON DOSSIER\EMAIL"
'Construct a safe file name from the message subject
msgFileName = 18432
'marche pas:
'msgFileName = Workbooks("Classeur1.xlsm").Sheets("Feuil1").[a6]
Set oRegEx = CreateObject("vbscript.regexp")
oRegEx.Global = True
oRegEx.Pattern = "[\/:*?""<>|]"
msgFileName = Trim(oRegEx.Replace(msgFileName, ""))
'Set the initial location and file name for SaveAs dialog
dlgSaveAs.InitialFileName = SpecialPath & "\" & msgFileName
'Show the SaveAs dialog and save the message as pdf
If dlgSaveAs.Show = -1 Then
strCurrentFile = dlgSaveAs.SelectedItems(1)
'Verify if pdf is selected
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
'Save as pdf
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
' close the document and Word
wrdDoc.Close
If bStarted Then wrdApp.Quit
'Cleanup
Set MyOlNamespace = Nothing
Set MySelectedItem = Nothing
Set wrdDoc = Nothing
Set wrdApp = Nothing
Set oRegEx = Nothing
End Sub