Save Email As PDF to Folder

Sub PRINT_EMAIL_PDF()

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)

Dim myUser As String

myUser = Environ("username")

FirstName = Split(myUser, " ")(0) 'Right of Space

LastName = Split(myUser, " ")(1) 'Left of Space

FirstNameInitial = Left(FirstName, 1)

'Get all selected items

Dim MyOlNamespace As Outlook.NameSpace

Set MyOlNamespace = Application.GetNamespace("MAPI")

Set MyOlSelection = Application.ActiveExplorer.Selection

'Make sure at least one item is selected

If MyOlSelection.Count <> 1 Then

Response = MsgBox("Please select a single item", vbExclamation, "Save as PDF")

Exit Sub

End If

'Retrieve the selected item

Set MySelectedItem = MyOlSelection.Item(1)

'Construct a safe file name from the message subject

Dim msgFileName As String

msgFileName = MySelectedItem.Subject

Set oRegEx = CreateObject("vbscript.regexp")

oRegEx.Global = True

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

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

If (msgFileName) Like "*CASH.CORRECTION.ENTRY*" Then

msgFileName = Split(msgFileName, "FILE NAME - ")(1)

pdfGrabDate1 = Split(msgFileName, ".TXT")(0)

pdfGrabDate2 = Right(pdfGrabDate1, 12)

pdfDate = Left(pdfGrabDate2, 6)

pdfDateYYYY1 = Left(pdfDate, 2)

pdfDateYYYY2 = "20" & pdfDateYYYY1

pdfDateDD = Right(pdfDate, 2)

pdfDateMM1 = Left(pdfDate, 4)

pdfDateMM2 = Right(pdfDateMM1, 2)

MyDate = pdfDateMM2 & pdfDateDD & pdfDateYYYY2

MyYear = Mid(MyDate, 5, 4)

MyMonth = Mid(MyDate, 1, 2)

MyMonth2 = Mid(MyDate, 1, 2)

MyDay = Mid(MyDate, 3, 2)

If MyMonth = "01" Then

MyMonth = "01_January"

End If

If MyMonth = "02" Then

MyMonth = "02_February"

End If

If MyMonth = "03" Then

MyMonth = "03_March"

End If

If MyMonth = "04" Then

MyMonth = "04_April"

End If

If MyMonth = "05" Then

MyMonth = "05_May"

End If

If MyMonth = "06" Then

MyMonth = "06_June"

End If

If MyMonth = "07" Then

MyMonth = "07_July"

End If

If MyMonth = "08" Then

MyMonth = "08_August"

End If

If MyMonth = "09" Then

MyMonth = "09_September"

End If

If MyMonth = "10" Then

MyMonth = "10_October"

End If

If MyMonth = "11" Then

MyMonth = "11_November"

End If

If MyMonth = "12" Then

MyMonth = "12_December"

End If

If MyDay = "01" Then

MyDay = "1"

End If

If MyDay = "02" Then

MyDay = "2"

End If

If MyDay = "03" Then

MyDay = "3"

End If

If MyDay = "04" Then

MyDay = "4"

End If

If MyDay = "05" Then

MyDay = "5"

End If

If MyDay = "06" Then

MyDay = "6"

End If

If MyDay = "07" Then

MyDay = "7"

End If

If MyDay = "08" Then

MyDay = "8"

End If

If MyDay = "09" Then

MyDay = "9"

End If

Set FSO = CreateObject("Scripting.FileSystemObject")

If FSO.FolderExists("\\server.com\jacksonville\FinAdj\Scanned_Batched_Work" & "\" & MyYear & "\" & "Manual_Batches" & "\" & MyMonth & "\" & MyDay & "\" & FirstName & "_" & LastName & "\") Then

ChDir "\\server.com\jacksonville\FinAdj\Scanned_Batched_Work" & "\" & MyYear & "\" & "Manual_Batches" & "\" & MyMonth & "\" & MyDay & "\" & FirstName & "_" & LastName & "\"

wrdApp.ActiveDocument.ExportAsFixedFormat OutputFileName:="\\server.com\jacksonville\FinAdj\Scanned_Batched_Work" & "\" & MyYear & "\" & "Manual_Batches" & "\" & MyMonth & "\" & MyDay & "\" & FirstName & "_" & LastName & "\" & msgFileName & ".pdf", 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

Else

Dim fs2, f2, ts2

Set fs2 = CreateObject("Scripting.FileSystemObject")

CheckMyFile:

If FSO.FolderExists("\\server.com\jacksonville\FinAdj\Scanned_Batched_Work" & "\" & MyYear & "\" & "Manual_Batches" & "\" & MyMonth & "\" & MyDay & "\" & FirstName & "_" & LastName & "\") Then

ChDir "\\server.com\jacksonville\FinAdj\Scanned_Batched_Work" & "\" & MyYear & "\" & "Manual_Batches" & "\" & MyMonth & "\" & MyDay & "\" & FirstName & "_" & LastName & "\"

GoTo EndProcess

ElseIf FSO.FolderExists("\\server.com\jacksonville\FinAdj\Scanned_Batched_Work" & "\" & MyYear & "\" & "Manual_Batches" & "\" & MyMonth & "\" & MyDay & "\") Then

Set f2 = fs2.CreateFolder("\\server.com\jacksonville\FinAdj\Scanned_Batched_Work" & "\" & MyYear & "\" & "Manual_Batches" & "\" & MyMonth & "\" & MyDay & "\" & FirstName & "_" & LastName & "\")

GoTo CheckMyFile

ElseIf FSO.FolderExists("\\server.com\jacksonville\FinAdj\Scanned_Batched_Work" & "\" & MyYear & "\" & "Manual_Batches" & "\" & MyMonth & "\") Then

Set f2 = fs2.CreateFolder("\\server.com\jacksonville\FinAdj\Scanned_Batched_Work" & "\" & MyYear & "\" & "Manual_Batches" & "\" & MyMonth & "\" & MyDay & "\")

GoTo CheckMyFile

ElseIf FSO.FolderExists("\\server.com\jacksonville\FinAdj\Scanned_Batched_Work" & "\" & MyYear & "\" & "Manual_Batches" & "\") Then

Set f2 = fs2.CreateFolder("\\server.com\jacksonville\FinAdj\Scanned_Batched_Work" & "\" & MyYear & "\" & "Manual_Batches" & "\" & MyMonth & "\")

GoTo CheckMyFile

ElseIf FSO.FolderExists("\\server.com\jacksonville\FinAdj\Scanned_Batched_Work" & "\" & MyYear & "\") Then

Set f2 = fs2.CreateFolder("\\server.com\jacksonville\FinAdj\Scanned_Batched_Work" & "\" & MyYear & "\" & "Manual_Batches" & "\")

GoTo CheckMyFile

ElseIf FSO.FolderExists("\\server.com\jacksonville\FinAdj\Scanned_Batched_Work" & "\") Then

Set f2 = fs2.CreateFolder("\\server.com\jacksonville\FinAdj\Scanned_Batched_Work" & "\" & MyYear & "\")

GoTo CheckMyFile

ElseIf FSO.FolderExists("\\server.com\jacksonville\FinAdj") Then

Set f2 = fs2.CreateFolder("\\server.com\jacksonville\FinAdj\Scanned_Batched_Work" & "\")

GoTo CheckMyFile

End If

EndProcess:

End If

Else

MsgBox "You've selected the wrong file! Please try again."

GoTo close_files

End If

Next obj

close_files:

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

Page updated

Google Sites

Report abuse