OK The following will work, provided there are no images in the original message body and the conditions are as you have described them.
If there are images in the message body then they need to be trapped (see my oprevious message). Change the message components at the top of the code to provide the covering message you want to send with the PDF. The process uses a temporary folder which is created first then deleted after use.
The process will not send the messages unless you release the .Send command so you can test it. Select a message with the image attachments and run the main macro.
If you have a problem comment out the line On Error Resume Next and run it again and see where it falls over.
Option Explicit
'Graham Mayor - http://www.gmayor.com - Last updated - 19 Jul 2018
'Modify these items as appropriate
Private Const strTo As String = "someone@somewhere.com"
Private Const strSubject As String = "Attached file"
Private Const strMsg As String = "This is the forwarded message body." & vbCr & _
"This is another line." & vbCr & _
"The default signature will be included"
Sub ProcessAttachments()
Dim strSaveFldr As String
Dim olMsg As Outlook.MailItem
Dim olFwd As Outlook.MailItem
Dim olInsp As Outlook.Inspector
Dim wdDoc As Object
Dim wdApp As Object
Dim oDoc As Object
Dim oRng As Object
Dim oNewRng As Object
Dim strFileName As String
Dim strPDFName As String
Dim iCount As Integer
Dim bWordWasNotRunning As Boolean
Dim oFSO As Object
strSaveFldr = Environ("TEMP") & "\TempSaveAttachments\"
CreateFolders strSaveFldr
On Error Resume Next
Set olMsg = ActiveExplorer.Selection.Item(1)
SaveAttachments olMsg, strSaveFldr
iCount = 0
strFileName = Dir$(strSaveFldr & "*.jpg")
While Len(strFileName) <> 0
iCount = iCount + 1
strFileName = Dir$()
Wend
If iCount > 0 Then
bWordWasNotRunning = False
Set wdApp = GetObject(, "Word.Application")
If Err Then
Set wdApp = CreateObject("Word.Application")
bWordWasNotRunning = True
End If
wdApp.Visible = True
Set oDoc = wdApp.Documents.Add
strFileName = Dir$(strSaveFldr & "*.jpg")
While Len(strFileName) <> 0
Set oRng = oDoc.Range
With oRng
.collapse 0
.InlineShapes.AddPicture _
fileName:=strSaveFldr & strFileName, _
LinkToFile:=False, _
SaveWithDocument:=True
End With
oDoc.Range.InsertParagraphAfter
strFileName = Dir$()
Wend
oDoc.Range.Paragraphs.Last.Range.Delete
strPDFName = strSaveFldr & "POA.pdf"
oDoc.ExportAsFixedFormat OutputFilename:=strPDFName, _
ExportFormat:=17, _
OpenAfterExport:=False, _
OptimizeFor:=0, _
Range:=0, _
From:=1, To:=1, _
Item:=0, _
IncludeDocProps:=True, _
KeepIRM:=True, _
CreateBookmarks:=1, _
DocStructureTags:=True, _
BitmapMissingFonts:=True, _
UseISO19005_1:=False
End If
oDoc.Close 0
If bWordWasNotRunning = True Then wdApp.Quit
Set olFwd = CreateItem(olMailItem)
With olFwd
.To = strTo
.Subject = strSubject
.Attachments.Add strPDFName
.Display
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
Set oNewRng = wdDoc.Range
oNewRng.collapse 1
oNewRng.Text = strMsg
'.Send 'remove apostrophe after testing
End With
Kill strSaveFldr & "*.jpg"
Kill strPDFName
Set oFSO = CreateObject("Scripting.FileSystemObject")
oFSO.DeleteFolder Environ("TEMP") & "\TempSaveAttachments"
lbl_Exit:
Set oFSO = Nothing
Set olMsg = Nothing
Set olFwd = Nothing
Set olInsp = Nothing
Set wdDoc = Nothing
Set wdApp = Nothing
Set oDoc = Nothing
Set oRng = Nothing
Set oNewRng = Nothing
Exit Sub
End Sub
Private Sub SaveAttachments(olItem As MailItem, strFldr As String)
'Graham Mayor - http://www.gmayor.com - Last updated - 26 May 2017
Dim olAttach As Attachment
Dim strFname As String
Dim strExt As String
Dim j As Long
On Error GoTo lbl_Exit
If olItem.Attachments.Count > 0 Then
For j = 1 To olItem.Attachments.Count
Set olAttach = olItem.Attachments(j)
'If Not olAttach.fileName Like "image*.*" Then
strFname = olAttach.fileName
olAttach.SaveAsFile strFldr & strFname
'olAttach.Delete 'delete the attachment
'End If
Next j
olItem.Save
End If
lbl_Exit:
Set olAttach = Nothing
Set olItem = Nothing
Exit Sub
End Sub
Private Sub CreateFolders(strPath As String)
'A Graham Mayor/Greg Maxey AddIn Utility Macro
Dim oFSO As Object
Dim lng_PathSep As Long
Dim lng_PS As Long
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
lng_PathSep = InStr(3, strPath, "\")
If lng_PathSep = 0 Then GoTo lbl_Exit
Set oFSO = CreateObject("Scripting.FileSystemObject")
Do
lng_PS = lng_PathSep
lng_PathSep = InStr(lng_PS + 1, strPath, "\")
If lng_PathSep = 0 Then Exit Do
If Len(Dir(Left(strPath, lng_PathSep), vbDirectory)) = 0 Then Exit Do
Loop
Do Until lng_PathSep = 0
If Not oFSO.FolderExists(Left(strPath, lng_PathSep)) Then
oFSO.CreateFolder Left(strPath, lng_PathSep)
End If
lng_PS = lng_PathSep
lng_PathSep = InStr(lng_PS + 1, strPath, "\")
Loop
lbl_Exit:
Set oFSO = Nothing
Exit Sub
End Sub