Insert picture to email body from the embedded object in excel

Vincent88

Active Member
Joined
Mar 5, 2021
Messages
382
Office Version
  1. 2019
Platform
  1. Windows
  2. Mobile
I use a code to embed image to excel (this part works fine), then how can I insert that image to an email body. Also I want to copy the text from column A of relative row (if I am in E3, then I want to copy A3 text) for the subject of email.

VBA Code:
Sub SelectOLE()
Dim objFileDialog As Office.FileDialog

    Set objFileDialog = Application.FileDialog(MsoFileDialogType.msoFileDialogFilePicker)

        objFileDialog.AllowMultiSelect = False
        objFileDialog.ButtonName = "Select File"
        objFileDialog.Title = "Select File"
        objFileDialog.Show

        If (objFileDialog.SelectedItems.Count > 0) Then
                    
        Set f = ActiveSheet.OLEObjects.Add _
            (Filename:=objFileDialog.SelectedItems(1), _
              Link:=False, _
              DisplayAsIcon:=True, _
              IconLabel:=objFileDialog.SelectedItems(1), _
              Top:=ActiveCell.Top, _
              Left:=ActiveCell.Left _
           )
        f.Select
        
        With f
       .ShapeRange.LockAspectRatio = msoFalse
       .Width = ActiveCell.Width
       .Height = ActiveCell.Height
        End With
        
          'f.Width = ActiveCell.Width
          'f.Height = ActiveCell.Height
      
        End If
        EmailChase
End Sub
Sub EmailChase()
    If ActiveWorkbook Is ThisWorkbook Then
    
       Dim ws As Worksheet
       Set ws = ActiveSheet
      
       Dim emailApplication As Object
       Dim emailItem As Object

       Set emailApplication = CreateObject("Outlook.Application")
       Set emailItem = emailApplication.CreateItem(0)
      
       Dim sp, ep As String
       sp = "<p style='font-family:Tahoma;font-size:10pt;mso-margin-top-alt:0.0pt;margin-bottom:0.0pt'>"
       ep = "</p><br>"
  
      
       strbody = sp & "Dear Francis," & ep _
                 & sp & "User chases this case. Please review." _
                 & sp & "<br>" _
                 & ep
       'Now insert the embedded picture here
                
       On Error Resume Next
      
       With emailItem
           .Display
           .To = "testingsample@gmail.com"
           '.CC = sh.Range("P2").Value
           '.BCC = sh.Range("Q2").Value
          
           '.Subject = ws.Range("a2").Text
           .Subject = ws.Range(Cells(Rows(), 1)).Text
          
           .HTMLBody = strbody & .HTMLBody
                            
      
        End With
        
        On Error GoTo 0

        Set emailItem = Nothing
        Set emailApplication = Nothing

    End If
    
End Sub
 

Excel Facts

Difference between two dates
Secret function! Use =DATEDIF(A2,B2,"Y")&" years"&=DATEDIF(A2,B2,"YM")&" months"&=DATEDIF(A2,B2,"MD")&" days"
Hi Vincent88,

you would need to alter the call to the procdure from
Code:
EmailChase
to
Code:
EmailChase2 ActiveCell.Row
and use the following procedure to test:
VBA Code:
Sub EmailChase2(lngRow As Long)
  Dim ws As Worksheet
  Dim emailApplication As Object
  Dim emailItem As Object
  Dim sp As String, ep As String, strBody As String
  Dim strFilePic As String
  Dim strPic As String

  If ActiveWorkbook Is ThisWorkbook Then
    Set ws = ActiveSheet
    Set emailApplication = CreateObject("Outlook.Application")
    Set emailItem = emailApplication.CreateItem(0)

    sp = "<p style='font-family:Tahoma;font-size:10pt;mso-margin-top-alt:0.0pt;margin-bottom:0.0pt'>"
    ep = "</p><br>"

    strBody = sp & "Dear Francis," & ep _
        & sp & "User chases this case. Please review." _
        & sp & "<br>" _
        & ep

    ' strFilePic = "E:\Wallpapers\Norm\10.jpg"
    strFilePic = ws.Cells(lngRow, 5).Value 'please adjust the column to suit your needs, here it`s Column E
    strPic = Mid(strFilePic, InStrRev(strFilePic, "\") + 1)

    On Error Resume Next
    With emailItem
      .Display
      .To = "testingsample@gmail.com"
      '.CC = sh.Range("P2").Value
      '.BCC = sh.Range("Q2").Value

       '.Subject = ws.Range("a2").Text
       .Subject = ws.Cells(lngRow, 1).Text
      .Attachments.Add strFilePic, 1, 0

      .HTMLBody = "<html><p>" & strBody & "</p><img src=""cid:" & strPic & """ width=480 height=400></html>"  'adjust width and height to suit
    End With

    On Error GoTo 0

    Set emailItem = Nothing
    Set emailApplication = Nothing

  End If

End Sub
Ciao,
Holger
 
Upvote 0
Hi HaHoBe,
email cannot display the image !
Is there any limitation of image extensions ( like jpg, png, tif etc ) to apply your code.
testcode.png
 
Upvote 0
Hi Vincent,

I would expect that the extensions you mentioned should work I tested with JPG and had no problems in doing so. Which format do you want to insert?

Ciao,
Holger
 
Upvote 0
Hi Vincent88,

when I tested the code before answering I related to my solution in this thread so that the path and filename appear in the cell next to the pic being inserted. If the referred cell is empty (I choose Column E for the code) no picture may be inserted as no information about the file is available.

If you just want to send an email once the code for input as well as creating email may be altered to pass the information as a second parameter.

HTH,
Holger
 
Upvote 0
Hi HaHoBe,
Your code can only show image with jpg format in outlook content. How about png, tif, bmp types ! Thanks in advance.
 
Last edited:
Upvote 0
Hi Vinvent88

on my computer it´s working well with JPG, GIF, PNG, and BMP. All expecting the fullname in the sheet.

But I´m the only one using the computer, what about asking IT if there are any restrictions being made?

Ciao,
Holger
 
Upvote 0
Hi Vincent,

in my file the path is laid down like

E:\Wallpapers\CO2_mascot-working.bmp

Are you using any network drives?

Ciao,
Holger
 
Upvote 0
Hi HaBoBe,
The code can display the jpg and png extension files now. But I found that my original vba (without insert images) can have outlook's default signature at the end of the message but after inserting image, it does not show. How to add the default signature back.
 
Upvote 0

Forum statistics

Threads
1,214,641
Messages
6,120,684
Members
448,977
Latest member
dbonilla0331

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top