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

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.

Code:

---

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

Code:

---

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:

You need to work with ranges e.g.

Set the variables used

Code:

---

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

Code:

---

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

---

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

Code:

---

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

---

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>

Attachment 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.

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

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

Code:

---

strPath = "C:\Path\" & Format(Date, " mmmm dd, yyyy\")

---

which is created if not present

Code:

---

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

Code:

---

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

---

Code:

---

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

---

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.

Code:

---

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

---

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."

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

Incidentally you have an error in your syntax

Code:

---

    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

Code:

---

    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

---

If i comment out the line

Code:

---

oShape.LockAspectRatio = msoTrue

---

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

I changed the code to read

Code:

---

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.

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

Code:

---

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

---