Save e-mail message as ".pdf" file in specified file path...

[sspatriots]

I'm using the following code to open a message box to select a cell and then call up the "HyperlinkFile" macro directly below this one. Is there any easy way to make this code convert the e-mail to a ".pdf" file and saving it into the folder in the specified file path rather than the ".msg" file?

Sub CreateHyperLink()
Dim myReply As Range

On Error Resume Next
Set myReply = Application.InputBox(prompt:="Please select any cell", Type:=8)
If myReply Is Nothing Then Exit Sub
myReply.Activate

HyperlinkFile


End Sub





Sub HyperlinkFile()
Dim xGetFile As Object
Dim fName As String, sFullFilename As String, sFileName As String

'Opens dialog box to Pick File to Hyperlink

Set xGetFile = Application.FileDialog(msoFileDialogFilePicker)
With xGetFile
.Title = "Spreadsheet Creative - Select File to Hyperlink"
If .Show = -1 Then
'Selected File full path
fName = .SelectedItems(1)

Else
fName = ""
End If
End With

'Test if user pressed cancel
If fName = "" Then Exit Sub
'Resume code

'Get File name from path
sFullFilename = Right(fName, Len(fName) - InStrRev(fName, "\"))
On Error Resume Next

'Change display text to the Selected File name WITHOUT FILE EXTENSION
'if you want to display the file extension then change the formula from sFileName to sFullFilename
'sFileName = Left(sFullFilename, (InStr(sFullFilename, ".") - 1))

sFileName = ActiveCell.Text

On Error Resume Next

'Add HYPERLINK formula to active cell
ActiveCell.Formula = "=HYPERLINK(""" & fName & """,""" & sFileName & """)"
End Sub

 

[JEC]

Just to give you an illustration (2 mail items to pdf).

Sub jec()
 Dim Xpath As String, i As Long
 Xpath = "C:\Users\xxx\Downloads\"
 
 With CreateObject("outlook.application").getnamespace("mapi").getdefaultfolder(6)
    For i = 1 To 2
      .Items(i).GetInspector.WordEditor.ExportAsFixedFormat Xpath & "testpdf.pdf", 17
    Next
 End With
End Sub

 

[sspatriots]

Good morning,

I tried the code that converts an e-mail to pdf above. It does seem to work, but for some reason it is grabbing the oldest e-mail in my inbox instead of the one that I have open that I want to save to a folder.


Thanks,

Steve

 

[sspatriots]

I've found the code below online, but not sure how to make it pop open a specific folder on my network that will allow me to direct it to a subfolder below where I actually want to place the pdf.

Sub SaveMessageAsPDF()

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 = WshShell.SpecialFolders(16)

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

Next obj
wrdDoc.Close
wrdApp.Quit
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