newparadigmz
asked on
Excel copy picture into Outlook email
Just need simple generic code to copy an existing picture from a worksheet, opening a Outlook email, and then paste the picture into the body, along with other fields (to:, subject:, etc..).
Should work with Excel 2003 :)
Thanks!
Should work with Excel 2003 :)
Thanks!
ASKER
Amazing! So much cleaner and "working" than what I was finding online (the word editor being the secret sauce here!).
Quick question. Instead of referring the picture by name, can I refer to the picture by the range (cell) that I know it sits in?
I'm running down a list of emails, each with a unique picture in the cell next to it.
Quick question. Instead of referring the picture by name, can I refer to the picture by the range (cell) that I know it sits in?
I'm running down a list of emails, each with a unique picture in the cell next to it.
Thanks for the feedback.
Well that's a tricky part.
Here is a workaround. The following code finds the picture in the cell next to the email cell considering the left and top positions are aligned with the left and top of the cell itself. The code assumes that the emails are listed in column A and the pictures are placed in column B. Change it as per your requirement. See if this approach works for you.
Well that's a tricky part.
Here is a workaround. The following code finds the picture in the cell next to the email cell considering the left and top positions are aligned with the left and top of the cell itself. The code assumes that the emails are listed in column A and the pictures are placed in column B. Change it as per your requirement. See if this approach works for you.
Dim shp As Shape
Sub CopyPictureToOutlook()
Dim ws As Worksheet
Dim EmailRng As Range, Cell As Range
Dim lr As Long
Dim olApp As Object
Dim olMail As Object
Dim olInsp As Object
Dim wdApp As Object
Dim Doc As Object
Dim DocSel As Object
Application.ScreenUpdating = False
Set ws = ActiveSheet 'Sheet which contains the picture
lr = ws.Cells(Rows.Count, 1).End(xlUp).Row 'Assuming emails are in col. A then finding the last row in col. A with an email
Set EmailRng = ws.Range("A2:A" & lr) 'Email range in col. A
Set olApp = CreateObject("Outlook.Application")
For Each Cell In EmailRng
Call GetPicture(Cell.Offset(0, 1)) 'Getting Picture name by its position in the cell next to the email cell
If Not shp Is Nothing Then
shp.Copy
Set olMail = olApp.CreateItem(0)
With olMail
.To = "Email ID here" 'Recipient's email address
.Subject = "Subject here" 'Subject line
.display 'Displays the email
'.send 'Uncomment to send the email
End With
Set olInsp = olMail.GetInspector
Set Doc = olInsp.WordEditor
Set wdApp = Doc.Application
Set DocSel = wdApp.Selection
DocSel.Paste
End If
Set shp = Nothing
Next Cell
Set DocSel = Nothing
Set Doc = Nothing
Set wdApp = Nothing
Set olInsp = Nothing
Set olMail = Nothing
Set olApp = Nothing
Application.ScreenUpdating = True
End Sub
Sub GetPicture(rng As Range)
Dim i As Long
For i = 1 To ActiveSheet.Shapes.Count
If ActiveSheet.Shapes(i).Left = rng.Left And ActiveSheet.Shapes(i).Top = rng.Top Then
Set shp = ActiveSheet.Shapes(i)
Exit For
End If
Next i
End Sub
ASKER
This totally works!
One last question please, How can I put text in the email above the picture?
So just text first, then picture below.
If I put it in olMail, pasting the picture, puts the picture before the text. I need to say something like, here is the picture below.
One last question please, How can I put text in the email above the picture?
So just text first, then picture below.
If I put it in olMail, pasting the picture, puts the picture before the text. I need to say something like, here is the picture below.
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
Thank you so much!!!
You're welcome. Glad I could help.
Change it as per your requirement.
Open in new window