Save email as PDF in outlook, and edit document in word

[rm7885]

Hello, I have a macro that I use that saves the selected email as a PDF, i tried to add to it so that it will turn all of the text in the email black, and re-size the images. If i set the document to visible the code works fine, but for some reason when I have visible:=false I get an error when trying to edit the email. This is the beginning of the code I have.


Sub SaveMessageAsPDF()


MapHDrive
'Select the messages to process and run this macro
Dim olMsg As MailItem
'Create the folder to store the messages if not present
If CreateFolders(strPath) = False Then GoTo lbl_Exit
'Open or Create a Word object
On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If Err Then
Set wdApp = CreateObject("Word.Application")
bStarted = True
End If
On Error GoTo lbl_Exit:
For Each olMsg In Application.ActiveExplorer.Selection
SaveAsPDFfile olMsg, wdApp
Next olMsg
lbl_Exit:
If bStarted Then wdApp.Quit
Set wdApp = Nothing
Exit Sub
End Sub


Sub SaveAsPDFfile(olItem As MailItem, wdApp As Object)
Dim FSO As Object, TmpFolder As Object
Dim tmppath As String
Dim strfilename As String
Dim strAttachPrefix As String
Dim strName As String
Dim oRegEx As Object


'Get the user's TempFolder to store the temporary file
Set FSO = CreateObject("Scripting.FileSystemObject")
tmppath = FSO.GetSpecialFolder(2)


'construct the filename for the temp mht-file
strName = "email_temp.mht"
tmppath = tmppath & "\" & strName


'Save temporary file
olItem.SaveAs tmppath, 10


'Open the temporary file in Word
Set wdDoc = wdApp.Documents.Open(Filename:=tmppath, _
AddToRecentFiles:=False, _
Visible:=False, _
Format:=7)


This is what I am trying to add


Selection.WholeStory
With Selection
.Font.Color = -587137025
End With
Dim pic As InlineShape
For Each pic In wdApp.ActiveDocument.InlineShapes
With pic
pic.LockAspectRatio = msoTrue
If pic.Width > wdApp.InchesToPoints(6.5) Then
pic.Width = wdApp.InchesToPoints(6.5)
Else ' vertical

End If

End With




Is it possible to do the edits to the document while it isn't visible? Also, do i need to add an If statement to check if there are any inlineshapes to prevent an error?:banghead:

[gmayor]

You need to work with ranges e.g.

Set the variables used


Dim wdApp As Object
Dim oShape As Object
Dim oRng As Object
Dim wdDoc As Object

Then as the document is already defined as wdDoc the following should work



Set oRng = wdDoc.Range
oRng.Font.Color = -587137025
For Each oShape In oRng.InlineShapes
With oShape
oShape.LockAspectRatio = msoTrue
If oShape.Width > wdApp.InchesToPoints(6.5) Then
oShape.Width = wdApp.InchesToPoints(6.5)
End If
End With
Next oShape

[rm7885]

Thank you for that, at first it seemed that worked, but it isnt consistent, for some reason, on certain emails it causes Word to crash, the error usually comes at the line "oShape.LockAspectRatio = msoTrue"

This is code I have there currently


Sub SaveMessageAsPDF()
MapHDrive
'Select the messages to process and run this macro
Dim olMsg As MailItem
'Create the folder to store the messages if not present
If CreateFolders(strPath) = False Then GoTo lbl_Exit
'Open or Create a Word object
On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If Err Then
Set wdApp = CreateObject("Word.Application")
bStarted = True
End If
On Error GoTo lbl_Exit:
objitem = GetCurrentItem
SaveAsPDFfile olMsg, wdApp
lbl_Exit:
If bStarted Then wdApp.Quit
Set wdApp = Nothing
Exit Sub
End Sub
Sub SaveAsPDFfile(olItem As MailItem, wdApp As Object)
Dim FSO As Object, TmpFolder As Object
Dim tmppath As String
Dim strfilename As String
Dim strAttachPrefix As String
Dim strName As String
Dim oRegEx As Object
Dim oShape As Object
Dim oRng As Object
'Get the user's TempFolder to store the temporary file
Set FSO = CreateObject("Scripting.FileSystemObject")
tmppath = FSO.GetSpecialFolder(2)
'construct the filename for the temp mht-file
strName = "email.mht"
tmppath = tmppath & "\" & strName
'Save temporary file
olItem.SaveAs tmppath, 10
'Open the temporary file in Word
Set wdDoc = wdApp.Documents.Open(Filename:=tmppath, _
AddToRecentFiles:=False, _
Visible:=False, _
Format:=7)

'Change Font color to black and resize images
Set oRng = wdDoc.Range
oRng.Font.Color = -587137025
For Each oShape In oRng.InlineShapes
With oShape
oShape.LockAspectRatio = msoTrue
If oShape.Width > wdApp.InchesToPoints(6.5) Then
oShape.Width = wdApp.InchesToPoints(6.5)
End If
End With
Next oShape


'Create a file name from the message subject
strfilename = InputBox("Enter claim number for message" & vbCr & _
olItem.subject, "Claim Number")
If strfilename = "" Then GoTo lbl_Exit


'Remove illegal filename characters
Set oRegEx = CreateObject("vbscript.regexp")
oRegEx.Global = True
oRegEx.Pattern = "[\/:*?""<>|]"
strfilename = Trim(oRegEx.Replace(strfilename, "")) & ".pdf"
strfilename = FileNameUnique(strPath, strfilename, "pdf")
strAttachPrefix = Replace(strfilename, ".pdf", "")
'save attachments
SaveAttachments olItem, strAttachPrefix
strfilename = strPath & Format(Date, "mmmm dd, yyyy") & "\" & strfilename
'Save As pdf
wdDoc.ExportAsFixedFormat OutputFileName:= _
strfilename, _
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

' close the document and Word
lbl_Exit:
wdDoc.Close 0
Set wdDoc = Nothing
Set oRegEx = Nothing
Exit Sub
End Sub

[gmayor]

Can you post a copy of a document it crashes on.
If you set the visibility to true, does it give any indication of the problem?
What does the error message say>

[rm7885]

13051

Attached is the email that is was giving me the error on, if I have it show it doesnt appear to give an error. If i debug and go one step at a time the error occurs on the line that locks the aspect ratio. The image in the email is a screenshot, not sure if that would matter.

[rm7885]

I have run the macro with that lock aspect ratio line removed, and it runs fine, and if there are no images it runs fine - im not sure why that line would cause word to crash

[gmayor]

The quoted part of your macro refers to items that are not declared and/or not present so it is difficult to evaluate what you have presented. I have changed some variable names and put in some functions that allow the macro to run (and commented out parts that are missing, in particular the reference to H drive and the call to save the attachments, which function is not present and which refers to a variable that is not part of the macro).

I have tested the macro below and it does not crash here. The macro will also reduce the image size to the quoted dimensions, so that part of the code works. The PDF is saved in the folder


strPath = "C:\Path\" & Format(Date, " mmmm dd, yyyy\")
which is created if not present

CreateFolders strPath
If you want to use an H drive, you will have to establish whether that drive exists before running the code at the start of the macro 'SaveMessageAsPDF"
You can do that with

IF Not FolderExists("H:\") Then GoTo lbl_Exit



Option Explicit
Private strPath As String
Private wdApp As Object
Private wdDoc As Object
Private bStarted As Boolean

Sub SaveMessageAsPDF()
'MapHDrive
'Select the messages to process and run this macro
Dim olMsg As MailItem
'Open or Create a Word object
Set olMsg = ActiveExplorer.Selection.Item(1)
On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If Err Then
Set wdApp = CreateObject("Word.Application")
bStarted = True
End If
On Error GoTo 0
SaveAsPDFfile olMsg, wdApp
lbl_Exit:
If bStarted Then wdApp.Quit
Set wdApp = Nothing
Exit Sub
End Sub

Sub SaveAsPDFfile(olItem As MailItem, wdApp As Object)
Dim FSO As Object, TmpFolder As Object
Dim tmppath As String
Dim strfilename As String
Dim strAttachPrefix As String
Dim strName As String
Dim oRegEx As Object
Dim oShape As Object
Dim oRng As Object
'Get the user's TempFolder to store the temporary file
Set FSO = CreateObject("Scripting.FileSystemObject")
tmppath = FSO.GetSpecialFolder(2)
'construct the filename for the temp mht-file
strName = "email.mht"
tmppath = tmppath & "\" & strName
'Save temporary file
olItem.SaveAs tmppath, 10
'Open the temporary file in Word
Set wdDoc = wdApp.Documents.Open(Filename:=tmppath, _
AddToRecentFiles:=False, _
Visible:=False, _
Format:=7)

'Change Font color to black and resize images
Set oRng = wdDoc.Range
oRng.Font.Color = -587137025
For Each oShape In oRng.InlineShapes
With oShape
oShape.LockAspectRatio = msoTrue
If oShape.Width > wdApp.InchesToPoints(6.5) Then
oShape.Width = wdApp.InchesToPoints(6.5)
End If
End With
Next oShape


'Create a file name from the message subject
strfilename = InputBox("Enter claim number for message" & vbCr & _
olItem.Subject, "Claim Number")
If strfilename = "" Then GoTo lbl_Exit


'Remove illegal filename characters
Set oRegEx = CreateObject("vbscript.regexp")
oRegEx.Global = True
oRegEx.Pattern = "[\/:*?""<>|]"
strfilename = Trim(oRegEx.Replace(strfilename, "")) & ".pdf"
strfilename = FileNameUnique(strPath, strfilename, "pdf")
strAttachPrefix = Replace(strfilename, ".pdf", "")
'save attachments
'SaveAttachments olItem, strAttachPrefix
strPath = "C:\Path\" & Format(Date, " mmmm dd, yyyy\")
CreateFolders strPath
strfilename = strPath & strfilename
'Save As pdf
wdDoc.ExportAsFixedFormat OutputFileName:= _
strfilename, _
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

' close the document and Word
lbl_Exit:
wdDoc.Close 0
Set wdDoc = Nothing
Set oRegEx = Nothing
Exit Sub
End Sub

Private Function FileNameUnique(strPath As String, _
strfilename As String, _
strExtension As String) As String
Dim lngF As Long
Dim lngName As Long
lngF = 1
lngName = Len(strfilename) - (Len(strExtension) + 1)
strfilename = Left(strfilename, lngName)
Do While FileExists(strPath & strfilename & Chr(46) & strExtension) = True
strfilename = Left(strfilename, lngName) & "(" & lngF & ")"
lngF = lngF + 1
Loop
FileNameUnique = strfilename & Chr(46) & strExtension
lbl_Exit:
Exit Function
End Function

Private Function FileExists(filespec) As Boolean
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FileExists(filespec) Then
FileExists = True
Else
FileExists = False
End If
lbl_Exit:
Exit Function
End Function

Private Function FolderExists(fldr) As Boolean
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
If (FSO.FolderExists(fldr)) Then
FolderExists = True
Else
FolderExists = False
End If
lbl_Exit:
Exit Function
End Function

Private Function CreateFolders(strPath As String)
Dim strTempPath As String
Dim lngPath As Long
Dim vPath As Variant
vPath = Split(strPath, "\")
strPath = vPath(0) & "\"
For lngPath = 1 To UBound(vPath)
strPath = strPath & vPath(lngPath) & "\"
If Not FolderExists(strPath) Then MkDir strPath
Next lngPath
lbl_Exit:
Exit Function
End Function

[rm7885]

I apologize for not including the entire code, here is the code with the functions that were omitted before, I am going to try the changes that you provided, and see if that doesn't resolve my problem.


Option Explicit
Private objitem As MailItem
Private wdApp As Object
Private wdDoc As Object
Private bStarted As Boolean
Const strPath As String = "H:\Uploads\"


Sub SaveMessageAsPDF()


MapHDrive
'Select the messages to process and run this macro
Dim olMsg As MailItem
'Create the folder to store the messages if not present
If CreateFolders(strPath) = False Then GoTo lbl_Exit
'Open or Create a Word object
On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If Err Then
Set wdApp = CreateObject("Word.Application")
bStarted = True
End If
On Error GoTo lbl_Exit:
For Each olMsg In Application.ActiveExplorer.Selection
SaveAsPDFfile olMsg, wdApp
Next olMsg
lbl_Exit:
If bStarted Then wdApp.Quit
Set wdApp = Nothing
Exit Sub
End Sub


Sub SaveAsPDFfile(olItem As MailItem, wdApp As Object)
Dim FSO As Object, TmpFolder As Object
Dim tmppath As String
Dim strfilename As String
Dim strAttachPrefix As String
Dim strName As String
Dim oRegEx As Object
Dim oShape As Object
Dim oRng As Object


'Get the user's TempFolder to store the temporary file
Set FSO = CreateObject("Scripting.FileSystemObject")
tmppath = FSO.GetSpecialFolder(2)


'construct the filename for the temp mht-file
strName = "email.mht"
tmppath = tmppath & "\" & strName


'Save temporary file
olItem.SaveAs tmppath, 10


'Open the temporary file in Word
Set wdDoc = wdApp.Documents.Open(Filename:=tmppath, _
AddToRecentFiles:=False, _
Visible:=False, _
Format:=7)

'Change Font color to black and resize images
Set oRng = wdDoc.Range
oRng.Font.Color = -587137025
For Each oShape In oRng.InlineShapes
With oShape
oShape.LockAspectRatio = msoTrue
End If
If oShape.Width > wdApp.InchesToPoints(6.5) Then
oShape.Width = wdApp.InchesToPoints(6.5)
End If
End With
Next oShape


'Create a file name from the message subject
strfilename = InputBox("Enter claim number for message" & vbCr & _
olItem.subject, "Claim Number")
If strfilename = "" Then GoTo lbl_Exit




'Remove illegal filename characters
Set oRegEx = CreateObject("vbscript.regexp")
oRegEx.Global = True
oRegEx.Pattern = "[\/:*?""<>|]"
strfilename = Trim(oRegEx.Replace(strfilename, "")) & ".pdf"
strfilename = FileNameUnique(strPath, strfilename, "pdf")
strAttachPrefix = Replace(strfilename, ".pdf", "")
'save attachments
SaveAttachments olItem, strAttachPrefix
strfilename = strPath & Format(Date, "mmmm dd, yyyy") & "\" & strfilename


'Save As pdf
wdDoc.ExportAsFixedFormat OutputFileName:= _
strfilename, _
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

' close the document and Word
lbl_Exit:
wdDoc.Close 0
Set wdDoc = Nothing
Set oRegEx = Nothing
Exit Sub
End Sub




Private Sub SaveAttachments(olItem As MailItem, strName As String)
Dim olAttach As Attachment
Dim strFname As String
Dim strExt As String
Dim strSaveFldr As String

strSaveFldr = strPath
CreateFolders strSaveFldr
On Error GoTo lbl_Exit
If olItem.Attachments.Count > 0 Then
For Each olAttach In olItem.Attachments
If Not olAttach.Filename Like "image*.*" Then
strFname = strName & "_" & olAttach.Filename
strExt = Right(strFname, Len(strFname) - InStrRev(strFname, Chr(46)))
strFname = FileNameUnique(strSaveFldr, strFname, strExt)
olAttach.SaveAsFile strSaveFldr & strFname
End If
Next olAttach
End If
lbl_Exit:
Set olAttach = Nothing
Exit Sub
End Sub


Private Function CreateFolders(strPath As String) As Boolean
Dim strTempPath As String
Dim lngPath As Long
Dim vPath As Variant
vPath = Split(strPath & Format(Date, "mmmm dd, yyyy"), "\")
strPath = vPath(0) & "\"
For lngPath = 1 To UBound(vPath)
strPath = strPath & vPath(lngPath) & "\"
On Error GoTo Err_Handler
If Not FolderExists(strPath) Then MkDir strPath
Next lngPath
CreateFolders = True
lbl_Exit:
Exit Function
Err_Handler:
MsgBox "The path " & strPath & " is invalid!"
CreateFolders = False
Resume lbl_Exit
End Function


Private Function FileNameUnique(strPath As String, _
strfilename As String, _
strExtension As String) As String
Dim lngF As Long
Dim lngName As Long
lngF = 1
lngName = Len(strfilename) - (Len(strExtension) + 1)
strfilename = Left(strfilename, lngName)
Do While FileExists(strPath & Format(Date, "mmmm dd, yyyy") & "\" & strfilename & Chr(46) & strExtension) = True
strfilename = Left(strfilename, lngName) & "(" & lngF & ")"
lngF = lngF + 1
Loop
FileNameUnique = strfilename & Chr(46) & strExtension
lbl_Exit:
Exit Function
End Function


Private Function FolderExists(ByVal PathName As String) As Boolean
Dim nAttr As Long
On Error GoTo NoFolder
nAttr = GetAttr(PathName)
If (nAttr And vbDirectory) = vbDirectory Then
FolderExists = True
End If
NoFolder:
Exit Function
End Function


Private Function FileExists(ByVal Filename As String) As Boolean
Dim nAttr As Long
On Error GoTo NoFile
nAttr = GetAttr(Filename)
If (nAttr And vbDirectory) <> vbDirectory Then
FileExists = True
End If
NoFile:
Exit Function
End Function


Function MapHDrive()
Dim oNetwork As Object, sDrive As String, sPath As String
If FolderExists("H:\") Then
GoTo Already_Mapped
Else
Set oNetwork = CreateObject("WScript.Network")
sDrive = "H:"
sPath = "\\ns-uticvfs01\" & (Environ$("Username"))
oNetwork.MapNetworkDrive sDrive, sPath
End If
Already_Mapped:
End Function
Function GetCurrentItem() As Object
Dim objApp As Outlook.Application

Set objApp = Application
On Error Resume Next
Select Case TypeName(objApp.ActiveWindow)
Case "Explorer"
Set GetCurrentItem = objApp.ActiveExplorer.Selection.Item(1)
Case "Inspector"
Set GetCurrentItem = objApp.ActiveInspector.CurrentItem
End Select

Set objApp = Nothing
End Function

[rm7885]

If I run the code you provided with Word open, it runs fine, but if I run the code and I do not have Word open it gives me the following error

"Run-time error '-2147023170 (800706be)':
Automation error
The remote procedure call failed."

[gmayor]

It is not uncommon for calls to create other applications to fail. Try repairing Office, or simply ensure Word is already running.

[gmayor]

Incidentally you have an error in your syntax



For Each oShape In oRng.InlineShapes
With oShape
oShape.LockAspectRatio = msoTrue
End If
If oShape.Width > wdApp.InchesToPoints(6.5) Then
oShape.Width = wdApp.InchesToPoints(6.5)
End If
End With
Next oShape


should read



For Each oShape In oRng.InlineShapes
oShape.LockAspectRatio = msoTrue
If oShape.Width > wdApp.InchesToPoints(6.5) Then
oShape.Width = wdApp.InchesToPoints(6.5)
End If
Next oShape

[rm7885]

If i comment out the line

oShape.LockAspectRatio = msoTrue

Then there is no error, and everything runs. Just confused as to why it would fail on that line.

[rm7885]

I changed the code to read


For Each oShape In oRng.InlineShapes
oShape.LockAspectRatio = msoTrue
If oShape.Width > wdApp.InchesToPoints(6.5) Then
oShape.Width = wdApp.InchesToPoints(6.5)
End If
Next oShape

But the code still fails at the same line.

[rm7885]

Sorry it took so long for me to get back to this, but I did resolve the issue I was having. For some reason whenever i tried to change the height or width using oshape.width or oshape.height Word would crash, so i was able to work around it by using oshape.scalewidth. I'm sure there is a cleaner, or nicer way to go about it, but this is what i ended up with


Set oRng = wdDoc.Range
oRng.Font.Color = -587137025
For Each oShape In oRng.InlineShapes
If oShape.Width > wdApp.InchesToPoints(6.5) Then
W = oShape.Width
PWidth = (468 / W) * 100
oShape.ScaleWidth = PWidth
End If
Next oShape