This function creates a word doc, saves and closes it, but is failing when I attempt to reopen. It says this at the remote call doesn't work. What is the proper practice for reopening a word doc? Or is it unnecessary to close and open again? It appears there is difficulty with communication between word and excel.
Sub tester()
Dim wordApp As Object
Dim wordDoc As Object
Dim appendDate As String
Set wordApp = CreateObject("Word.Application")
wordApp.Visible = True
appendDate = "Y"
fName = "robot"
If appendDate = "Y" Or appendDate = "y" Then
fName = ThisWorkbook.Path & "\" & fName & "-" & Format(Now(), "yyyymmdd-hhmm") & ".docx"
Else
fName = ThisWorkbook.Path & "\" & fName & ".docx"
End If
wordApp.Documents.Add.SaveAs2 fileName:=fName
wordApp.Documents.Close
wordApp.Application.Quit
Set wordDoc = wordApp.Documents.Open(fileName:=fPath, readOnly:=False)
ThisWorkbook.Sheets("Sheet1").ChartObjects(1).Activate
ActiveChart.ChartArea.Copy
wordDoc.Application.Selection.PasteSpecial Link:=False, DataType:=wdPasteOLEObject, Placement:=wdInLine
End Sub
Since you quit the Word.Application then there's no more wordApp, so Documents.Open has no environment in which to execute.
If you want to open a file at any point, directly, without first starting the application you can use GetObject:
Set wordDoc = GetObject(FName)
If you need to address the Word.Application at a later point, after using GetObject to open the file:
Set wordApp = wordDoc.Application
This is how I would do it
Option Explicit
Const wdFormatXMLDocument As Integer = 12
Sub tester()
Dim wordApp As Object, wordDoc As Object
Dim appendDate As String, FName As String
Set wordApp = CreateObject("Word.Application")
wordApp.Visible = True
appendDate = "Y"
FName = "robot"
If UCase(appendDate) = "Y" Then '<~~ Unsure of this as you are already setting the value of Y
FName = ThisWorkbook.Path & "\" & FName & "-" & Format(Now(), "yyyymmdd-hhmm") & ".docx"
Else
FName = ThisWorkbook.Path & "\" & FName & ".docx"
End If
Set wordDoc = wordApp.Documents.Add
ThisWorkbook.Sheets("Sheet1").ChartObjects(1).Activate
ActiveChart.ChartArea.Copy
wordApp.Selection.PasteSpecial Link:=False, DataType:=0, Placement:=0
wordDoc.SaveAs2 Filename:=FName, FileFormat:=wdFormatXMLDocument
wordDoc.Close (False)
wordApp.Quit
Set wordDoc = Nothing
Set wordApp = Nothing
End Sub
Screenshot
Related
I want to convert a list of text files in a particular folder into PDF.
I have written logic to open a single text file from Word document to be saved in a PDF format but it is not saved as a PDF file.
This is Excel VBA.
Dim file As Variant
inp_dir = "C:\Users\HP\OneDrive\Desktop\vbatest\pdfconv\"
inp_file_name = Dir(inp_dir & "*.txt") 'txt path
inp_file = inp_dir & inp_file_name
Dim wdApp As New Word.Application, wdDoc As Word.Document
MsgBox (inp_file)
' Set wdDoc = Documents.Open(inp_file)
Set wdDoc = Documents.Open(Filename:=inp_file, ReadOnly:=True, _
AddToRecentFiles:=False, Format:=wdOpenFormatAuto, Visible:=False)
wdDoc.SaveAs2 Filename:="inp_file" & Replace(inp_file, ".txt", ".pdf"), _
FileFormat:=wdFormatPDF, AddToRecentFiles:=False
wdDoc.Close False
I guess you are close - you just have a small mistake in your destination file name: You write Filename:="inp_file" & Replace(inp_file, ".txt", ".pdf"), but the fixed string "inp_file" makes no sense and invalidates the filename.
I always advice to use intermediate variables, with that it gets much easier to debug and to find errors.
Some more small things:
You should use Option Explicit and declare all variables.
You have a variable file declared that is never used.
declare your path as Constant
Your code could look like:
Const inp_dir = "C:\Users\HP\OneDrive\Desktop\vbatest\pdfconv\"
Dim inp_file_name As String, inp_full_name As String
inp_file_name = Dir(inp_dir & "*.txt") 'txt path
inp_full_name = inp_dir & inp_file_name
Dim wdApp As New Word.Application, wdDoc As Word.Document
Set wdDoc = wdApp.Documents.Open(Filename:=inp_full_name, ReadOnly:=True, _
AddToRecentFiles:=False, Format:=wdOpenFormatAuto, Visible:=False)
Dim pdf_Filename As String
pdf_Filename = Replace(inp_full_name, ".txt", ".pdf")
Debug.Print pdf_Filename
wdDoc.SaveAs2 Filename:=pdf_Filename, FileFormat:=wdFormatPDF, AddToRecentFiles:=False
wdDoc.Close False
wdApp.Quit
Your code is very close to running. Basically you need to open Word using your wdApp object. This example shows how...
Option Explicit
Sub TxtToPDF()
Dim inp_dir As String
Dim inp_file_name As String
Dim inp_file As String
inp_dir = "C:\Temp\"
inp_file_name = Dir(inp_dir & "*.txt") 'txt path
Dim wordWasRunning As Boolean
wordWasRunning = IsMSWordRunning
Dim wdApp As Word.Application
Set wdApp = AttachToMSWordApplication
Do While Len(inp_file_name) > 0
inp_file = inp_dir & inp_file_name
Debug.Print "currently opening " & inp_file
Dim wdDoc As Word.Document
Set wdDoc = wdApp.Documents.Open(Filename:=inp_file, _
ReadOnly:=True, _
AddToRecentFiles:=False, _
Format:=wdOpenFormatAuto, _
Visible:=False)
Dim out_file As String
out_file = Replace(inp_file, ".txt", ".pdf")
Debug.Print "saving as " & out_file
wdDoc.SaveAs2 Filename:=out_file, _
FileFormat:=wdFormatPDF, AddToRecentFiles:=False
wdDoc.Close False
'--- get the next txt file
inp_file_name = Dir
Loop
If Not wordWasRunning Then
wdApp.Quit
End If
End Sub
Put this code in another module to use (from my personal library).
Option Explicit
Public Function IsMSWordRunning() As Boolean
'--- quick check to see if an instance of MS Word is running
Dim msApp As Object
On Error Resume Next
Set msApp = GetObject(, "Word.Application")
If Err > 0 Then
'--- not running
IsMSWordRunning = False
Else
'--- running
IsMSWordRunning = True
End If
End Function
Public Function AttachToMSWordApplication() As Word.Application
'--- finds an existing and running instance of MS Word, or starts
' the application if one is not already running
Dim msApp As Word.Application
On Error Resume Next
Set msApp = GetObject(, "Word.Application")
If Err > 0 Then
'--- we have to start one
' an exception will be raised if the application is not installed
Set msApp = CreateObject("Word.Application")
End If
Set AttachToMSWordApplication = msApp
End Function
I have a couple of excels I am messing around with practicing VBA. They all at have code to mail merge. On one excel I subtract the row number from the row where my headers are. For example my headers are on row 22 and my data starts at row 23. So I subtract 22 from the row number and it begins the mail merge from there (or it only starts to count records from there. I am unsure). So if I have 3 rows of data that would be row 23 to 25. The code subtracts 22 and I am left with 3 records to mail merge. I am learning VBA so I have a hard time figuring out the code I need to only do the last row. Here is my mail merge code:
Private intakeForm As String
Private wdApp As Word.Application
Public newFilePath As String
Public newFolderName As String
Sub MailMergeAutomation()
Dim filePath As String
filePath = ThisWorkbook.Path & "\" & "Forms" & "\"
Dim wdDoc As Word.Document
Dim TargetDoc As Word.Document
Dim recordNumber As Long
Dim selRow As Range
Set selRow = Selection
intakeForm = "New Intake Form"
recordNumber = selRow.Row
Set fso = New Scripting.FileSystemObject
Set wdApp = New Word.Application
If wdApp Is Nothing Then
Set wdApp = New Word.Application
End If
Set fso = New FileSystemObject
With wdApp
.Visible = False
Set wdDoc = .Documents.Open(filePath & intakeForm)
wdDoc.MailMerge.MainDocumentType = wdFormLetters
wdDoc.MailMerge.OpenDataSource _
Name:=ThisWorkbook.Path & "\" & ThisWorkbook.Name, _
AddToRecentFiles:=False, _
Revert:=False, _
Format:=wdOpenFormatAuto, _
Connection:="Data Source=" & ThisWorkbook.Path & "\" & ThisWorkbook.Name & ";Mode=Read", _
SQLStatement:="SELECT * FROM [Headers]"
With wdDoc.MailMerge
.Destination = wdSendToNewDocument
With .DataSource
.FirstRecord = recordNumber - 22
.LastRecord = recordNumber - 22
'.ActiveRecord = .Ac
.LastRecord = recordNumber - 22
End With
.Execute Pause:=False
wdApp.Visible = False
Set TargetDoc = wdApp.ActiveDocument
TargetDoc.SaveAs2 Filename:=ThisWorkbook.Path & "\" & Sheet1.Cells(recordNumber, 3) & " " & "- intakeForm.docx"
wdDoc.Close SaveChanges:=False
End With
End With
Set wdDoc = Nothing
wdApp.Quit
Set wdApp = Nothing
End Sub
The easiest and simplest way to get the last row is usually something like sht.Cells(sht.Rows.Count, "A").End(xlUp).Row and should help you. There are a few other ways of doing it too, so for the record - 5 Different Ways to Find The Last Row or Last Column Using VBA
So I got the project working with opening the .dotx and inserting the values from the excel file and saving as .docx.
But I can't for the life of me get it to save as .pdf instead. Well I can, but the pdf can't be opened.
Sub Cost_Statement()
Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Dim i As Integer
Set wrdApp = CreateObject("Word.Application")
wrdApp.Visible = False
Application.ScreenUpdating = True
TemplateLocation = "C:\Custom documents\Cost_statement.dotx"
Set wrdDoc = wrdApp.Documents.Add(TemplateLocation, False, , False)
On Error GoTo NextNumber
cellno = "Main!C19"
FindText2 = "<<EXCELCOST>>"
ReplacementText2 = Range(cellno).Value
wrdDoc.Content.Find.Execute FindText2, ReplaceWith:=ReplacementText2, Replace:=wdReplaceAll
cellno = "Main!C20"
FindText3 = "<<EXCELDEST>>"
ReplacementText3 = Range(cellno).Value
wrdDoc.Content.Find.Execute FindText3, ReplaceWith:=ReplacementText3, Replace:=wdReplaceAll
NextNumber:
FileAddress = Range("Main!C21").Text
FileAddress = "C:\Cost Statement pdfs\" & FileAddress & ".docx"
With wrdDoc
.SaveAs (FileAddress)
.Close
End With
wrdApp.Quit
Set wrdDoc = Nothing
Set wrdApp = Nothing
End Sub
Any help would be appreciated.
Did you try this way?
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:="C:\PathPDF.pdf"
also note that
FileAddress = Range("Main!C21").Text
FileAddress = "C:\Cost Statement pdfs\" & FileAddress & ".docx"
is the same as
FileAddress = "C:\Cost Statement pdfs\" & FileAddress & ".docx"
While piecing together this code, I was able to get it function properly. Thinking I was done, I submitted it to someone who tried to add it as a personal macro and that was when we realized it didn't work the same. To verify, I added it as a personal macro on my own computer and it still didn't work.
I have blindly tried a handful of code additions such as ChartObject.Activate after ThisWorkbook.Activate but have not had success.
Sub RangeToEmailBody()
Dim TempFilePath As String
Dim xOutApp As Object
Dim xOutMail As Object
Dim xHTMLBody As String
Dim xRg As Range
On Error Resume Next
Set xRg = Application.InputBox(prompt:="Please select the data range:", Type:=8)
If xRg Is Nothing Then Exit Sub
With Application
.Calculation = xlManual
.ScreenUpdating = False
.EnableEvents = False
End With
Set xOutApp = CreateObject("outlook.application")
Set xOutMail = xOutApp.CreateItem(olMailItem)
Call createJpg(ActiveSheet.Name, xRg.Address, "DashboardFile")
TempFilePath = Environ$("temp") & "\"
xHTMLBody = "<span LANG=EN>" _
& "<p class=style2><span LANG=EN><font FACE=Calibri SIZE=3>" _
& "<img src='cid:DashboardFile.jpg'>"
With xOutMail
.Subject = ""
.HTMLBody = xHTMLBody
.Attachments.Add TempFilePath & "DashboardFile.jpg", olByValue
.To = " "
.Cc = " "
.Display
End With
End Sub
Sub createJpg(SheetName As String, xRgAddrss As String, nameFile As String)
Dim xRgPic As Range
ThisWorkbook.Activate
Worksheets(SheetName).Activate
Set xRgPic = ThisWorkbook.Worksheets(SheetName).Range(xRgAddrss)
xRgPic.CopyPicture
With ThisWorkbook.Worksheets(SheetName).ChartObjects.Add(xRgPic.Left, xRgPic.Top, xRgPic.Width, xRgPic.Height)
.Activate
.Chart.Paste
.Chart.Export Environ$("temp") & "\" & nameFile & ".jpg", "JPG"
End With
Worksheets(SheetName).ChartObjects(Worksheets(SheetName).ChartObjects.Count).Delete
Set xRgPic = Nothing
End Sub
I would expect the selected range to show up in the body of the email but as a personal macro, there is no content inside the "picture".
This is a guess at the problem. If you're adding this in a personal macro, ThisWorkbook refers to the personal workbook. I'm guessing your source range is in a different workbook entirely.
To simplify, I'd do something like this, using a temporary new workbook:
Sub createJpg(rng As Range, nameFile As String)
Dim tempChartObj As ChartObject
Dim tempWb As Workbook
Set tempWb = Workbooks.Add
Set tempChartObj = tempWb.Sheets(1).ChartObjects.Add(rng.Left, rng.Top, rng.Width, rng.Height)
rng.CopyPicture
With tempChartObj
.Activate
.Chart.Paste
.Chart.Export Environ$("temp") & "\" & nameFile & ".jpg", "JPG"
End With
tempWb.Close SaveChanges:=False
End Sub
Then call it like this (note that Call is unnecessary):
createJpg xRg, "DashboardFile"
I have an Excel VBA script that creates a pdf of the active worksheet and then sends an email with Outlook with the pdf attached.
Then I have a rule in Outlook that runs a script on Emails that arrive in the Sent folder based on keywords in the subject that saves a pdf copy of that email and/or it's attachments.
I would rather just have the Excel VBA script save that pdf copy of the email that was just sent by the excel vba script. Otherwise, I would need to implement the Outlook "run as script" rule on every computer in our system.
How can I marry the Outlook script with the Excel script??
Excel Code to send email (works fine):
Sub AttachActiveSheetPDF_01()
Dim IsCreated As Boolean
Dim PdfFile As String, Title As String
Dim OutlApp As Object
' Define PDF filename
Title = Range("C218").Value
PdfFile = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & Title & ".pdf"
' Exportactivesheet as PDF
With ActiveSheet
.ExportAsFixedFormat Type:=xlTypePDF, FileName:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
End With
' Use already open Outlook if possible
On Error Resume Next
Set OutlApp = GetObject(, "Outlook.Application")
If Err Then
Set OutlApp = CreateObject("Outlook.Application")
IsCreated = True
End If
OutlApp.Visible = True
On Error GoTo 0
' Prepare e-mail with PDF attachment
With OutlApp.CreateItem(0)
' Prepare e-mail
.Subject = Title
.To = "" ' <-- Put email of the recipient here
.CC = "" ' <-- Put email of 'copy to' recipient here
.Body = "Hello," & vbLf & vbLf _
& "Please find attached a completed case review." & vbLf & vbLf _
& "Thank you," & vbLf _
& Application.UserName & vbLf & vbLf
.Attachments.Add PdfFile
' Try to send
Application.Visible = True
.Display
End With
' Quit Outlook if it was not already open
If IsCreated Then OutlApp.Quit
' Release the memory of object variable
Set OutlApp = Nothing
End Sub
Outlook script to save pdf copy of email (works fine):
Function CleanFileName(strText As String) As String
Dim strStripChars As String
Dim intLen As Integer
Dim i As Integer
strStripChars = "/\[]:=," & Chr(34)
intLen = Len(strStripChars)
strText = Trim(strText)
For i = 1 To intLen
strText = Replace(strText, Mid(strStripChars, i, 1), "")
Next
CleanFileName = strText
End Function
Sub SaveAsPDF(MyMail As MailItem)
' ### Requires reference to Microsoft Scripting Runtime ###
' ### Requires reference to Microsoft Word Object Library ###
' --- In VBE click TOOLS > REFERENCES and check the boxes for both of the above ---
Dim fso As FileSystemObject
Dim strSubject As String
Dim strSaveName As String
Dim blnOverwrite As Boolean
Dim strFolderPath As String
Dim sendEmailAddr As String
Dim senderName As String
Dim looper As Integer
Dim plooper As Integer
Dim strID As String
Dim olNS As Outlook.NameSpace
Dim oMail As Outlook.MailItem
strID = MyMail.EntryID
Set olNS = Application.GetNamespace("MAPI")
Set oMail = olNS.GetItemFromID(strID)
' ### Get username portion of sender email address ###
sendEmailAddr = oMail.SenderEmailAddress
senderName = Left(sendEmailAddr, InStr(sendEmailAddr, "#") - 1)
' ### USER OPTIONS ###
blnOverwrite = False ' False = don't overwrite, True = do overwrite
' ### Path to save directory ###
bPath = "Z:\email\"
' ### Create Directory if it doesnt exist ###
If Dir(bPath, vbDirectory) = vbNullString Then
MkDir bPath
End If
' ### Get Email subject & set name to be saved as ###
emailSubject = CleanFileName(oMail.Subject)
saveName = Format(oMail.ReceivedTime, "yyyy-mm-dd-hhmm") & "_" & emailSubject & ".mht"
Set fso = CreateObject("Scripting.FileSystemObject")
' ### Increment filename if it already exists ###
If blnOverwrite = False Then
looper = 0
Do While fso.FileExists(bPath & saveName)
looper = looper + 1
saveName = Format(oMail.ReceivedTime, "yyyy-mm-dd-hhmm") & "_" & senderName & "_" & emailSubject & "_" & looper & ".mht"
Loop
Else
End If
' ### Save .mht file to create pdf from Word ###
oMail.SaveAs bPath & saveName, olMHTML
pdfSave = bPath & Format(oMail.ReceivedTime, "yyyy-mm-dd-hhmm") & "_" & senderName & "_" & emailSubject & ".pdf"
If fso.FileExists(pdfSave) Then
plooper = 0
Do While fso.FileExists(pdfSave)
plooper = plooper + 1
pdfSave = bPath & Format(oMail.ReceivedTime, "yyyy-mm-dd-hhmm") & "_" & senderName & "_" & emailSubject & "_" & plooper &
".pdf"
Loop
Else
End If
' ### Open Word to convert .mht file to PDF ###
Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Set wrdApp = CreateObject("Word.Application")
' ### Open .mht file we just saved and export as PDF ###
Set wrdDoc = wrdApp.Documents.Open(FileName:=bPath & saveName, Visible:=True)
wrdApp.ActiveDocument.ExportAsFixedFormat OutputFileName:= _
pdfSave, 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
wrdDoc.Close
wrdApp.Quit
' ### Delete .mht file ###
Kill bPath & saveName
' ### Uncomment this section to save attachments ###
'If oMail.Attachments.Count > 0 Then
' For Each atmt In oMail.Attachments
' atmtName = CleanFileName(atmt.FileName)
' atmtSave = bPath & Format(oMail.ReceivedTime, "yyyy-mm-dd-hhmm") & "_" & atmtName
' atmt.SaveAsFile atmtSave
' Next
'End If
Set oMail = Nothing
Set olNS = Nothing
Set fso = Nothing
End Sub
It shouldn't be hard to change your outlook-vba to excel-vba, just move your outlook script to Excel Module and modify the following line.
Set App = CreateObject("Outlook.Application") '<- add
Set olNS = App.GetNamespace("MAPI") '<- change
Now create new Module and add the following code
Option Explicit
Sub Outlook()
Dim olNameSpace As Outlook.Namespace
Dim olApp As Outlook.Application
Dim olFolder As Outlook.MAPIFolder
Dim olItem As Object
Set olApp = CreateObject("Outlook.Application")
Set olNameSpace = olApp.GetNamespace("MAPI")
Set olFolder = olNameSpace.GetDefaultFolder(olFolderSentMail)
Set olItem = olApp.CreateItem(olMailItem)
For Each olItem In olFolder.Items
If olItem.Class = olMail Then
If olItem.Subject = [A1] Then '< - update cell range
Debug.Print olItem
SaveAsPDF olItem '< - Call SaveAsPDF code
End If
End If
Next
End Sub
the code will search outlook sent folder by [Subject] so update to mach your Excel code [Subject Title range]
If olItem.Subject = [A1] Then ' Update cell [C218]
If subject found then call outlook script
SaveAsPDF olItem
Remember to add - in VBE click TOOLS > REFERENCES and check the boxes for
Microsoft Outlook Object Library & Microsoft Scripting Runtime
Here is my final combined working code if anyone is interested (all in 1 module)
All props for combining code goes to Om3r who's got a frosty Colorado microbrew waiting for him!
This code will:
Create a PDF of Active Worksheet, Attach it to Email
After user sends email, searches Sent Mail folder for that email
Saves a PDF copy of the sent email (and attachments if desired)
Sorry about the 'pre' format but ctrl+K wasn't cutting it! Scratch that, got it
Sub AttachActiveSheetPDF()
Dim IsCreated As Boolean
Dim PdfFile As String, Esub As String
Dim OutlApp As Object
Dim sendTime As String
sendTime = Now()
sendTime = Format(sendTime, "yyyy-mm-dd-hhmmss")
' ### Define email subject and PDF path & filename ###
Esub = sendTime & "_Completed Case Review"
PdfFile = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & Esub & ".pdf"
' ### Export ActiveSheet to PDF ###
With ActiveSheet
.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
End With
' ### Open Outlook ###
On Error Resume Next
Set OutlApp = GetObject(, "Outlook.Application") '<-- If open, use it
If Err Then
Set OutlApp = CreateObject("Outlook.Application") '<-- If not, open it
IsCreated = True
End If
OutlApp.Visible = True
On Error GoTo 0
' ### Prepare email and attach pdf created above ###
With OutlApp.CreateItem(0)
.Subject = Esub
.To = "" ' <-- Put email of the recipient here
.CC = ""
.Body = "Hello," & vbLf & vbLf _
& "Please find attached a completed case review." & vbLf & vbLf _
& "Thank you," & vbLf _
& Application.UserName & vbLf & vbLf
.Attachments.Add PdfFile
' Try to send
Application.Visible = True
.Display True '<-- True forces code to wait for user to send email. Or just automate what the user is doing and change this to .Send
End With
Application.Wait (Now + TimeValue("0:00:05")) '<-- 5 second delay allows email to finish sending
' ### Search Sent Mail folder for emails with same timestamp in subject ###
Dim olNameSpace As Outlook.Namespace
Dim olFolder As Outlook.MAPIFolder
Dim olItem As Object
Set olNameSpace = OutlApp.GetNamespace("MAPI")
Set olFolder = olNameSpace.GetDefaultFolder(olFolderSentMail)
Set olItem = OutlApp.CreateItem(olMailItem)
For Each olItem In olFolder.Items
If olItem.Class = olMail Then
If olItem.Subject = Esub Then '<-- check for match
SaveAsPDF olItem '< - Call SaveAsPDF code
End If
End If
Next
If IsCreated Then OutlApp.Quit '<-- Quit Outlook if it was not already open
Set OutlApp = Nothing '<-- Release the memory of object variable
' ### Delete our temp pdf file if not needed anymore ###
Kill PdfFile
End Sub
Sub SaveAsPDF(MyMail As MailItem)
' ### Requires reference to Microsoft Scripting Runtime ###
' ### Requires reference to Microsoft Outlook Object Library ###
' ### Requires reference to Microsoft Word Object Library ###
' --- In VBE click TOOLS > REFERENCES and check the boxes for all of the above ---
Dim fso As FileSystemObject
Dim emailSubject As String
Dim saveName As String
Dim blnOverwrite As Boolean
Dim bPath As String
Dim strFolderPath As String
Dim sendEmailAddr As String
Dim senderName As String
Dim looper As Integer
Dim plooper As Integer
Dim strID As String
Dim olNS As Outlook.Namespace
Dim oMail As Outlook.MailItem
strID = MyMail.EntryID
Set App = CreateObject("Outlook.Application")
Set olNS = App.GetNamespace("MAPI")
Set oMail = olNS.GetItemFromID(strID)
' ### Get username portion of sender's email address ###
sendEmailAddr = oMail.SenderEmailAddress
senderName = Left(sendEmailAddr, InStr(sendEmailAddr, "#") - 1)
' ### USER OPTIONS ###
blnOverwrite = False ' False = don't overwrite, True = do overwrite
' ### Path to directory for saving pdf copy of sent email ###
bPath = "Z:\MyEmailFolder\"
' ### Create Directory if it doesnt exist ###
If Dir(bPath, vbDirectory) = vbNullString Then
MkDir bPath
End If
' ### Get Email subject & set name to be saved as ###
emailSubject = CleanFileName(oMail.Subject)
saveName = emailSubject & ".mht"
Set fso = CreateObject("Scripting.FileSystemObject")
' ### Save .mht file to create pdf from within Word ###
oMail.SaveAs bPath & saveName, olMHTML
pdfSave = bPath & emailSubject & "_" & senderName & "_" & ".pdf"
' ### Open Word to convert .mht file to PDF ###
Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Set wrdApp = CreateObject("Word.Application")
' ### Open .mht file we just saved and export as PDF ###
Set wrdDoc = wrdApp.Documents.Open(Filename:=bPath & saveName, Visible:=True)
wrdApp.ActiveDocument.ExportAsFixedFormat OutputFileName:= _
pdfSave, 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
wrdDoc.Close
wrdApp.Quit
' ### Delete our temp .mht file ###
Kill bPath & saveName
' ### Uncomment this section to save attachments also ###
'If oMail.Attachments.Count > 0 Then
' For Each atmt In oMail.Attachments
' atmtName = CleanFileName(atmt.FileName)
' atmtSave = bPath & Format(oMail.ReceivedTime, "yyyy-mm-dd-hhmm") & "_" & atmtName
' atmt.SaveAsFile atmtSave
' Next
'End If
Set oMail = Nothing
Set olNS = Nothing
Set fso = Nothing
End Sub
Function CleanFileName(strText As String) As String
Dim strStripChars As String
Dim intLen As Integer
Dim i As Integer
strStripChars = "/\[]:=," & Chr(34)
intLen = Len(strStripChars)
strText = Trim(strText)
For i = 1 To intLen
strText = Replace(strText, Mid(strStripChars, i, 1), "")
Next
CleanFileName = strText
End Function