Embedded Files
Good for 2007 and 2010 Outlook
Sub print_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)
MyDate = Format(Date, "mmddyyyy")
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
'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, ""))
msgFileName = Split(msgFileName, "FILE NAME - ")(1)
strToSaveAs = "\\Server\Folder" & "\" & MyYear & "\" & "Manual_Batches" & "\" & MyMonth & "\" & MyDay & "\" & FirstName & "_" & LastName & "\" & msgFileName & ".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 = "\\Server\Folder" & "\" & MyYear & "\" & "Manual_Batches" & "\" & MyMonth & "\" & MyDay & "\" & FirstName & "_" & LastName & "\" & msgFileName & ".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
Page updated
Google Sites
Report abuse