Copy Pictures from worksheet and add as Outlook attachments

DwinZly

Board Regular
Joined
Oct 26, 2009
Messages
56
Have been searching for hours and can't find anything to answer this...
I have a worksheet that users will insert pictures (jpeg, gif etc.) as visual aids.
What I would like is a way to extract all of the object images present on the worksheet and insert them as attachments in an Outlook email. I already have an email Sub...just can't figure out how to get the pictures into it. My routine is below:

Code:
Sub SendWorkBook()

Dim outlookApp As Object
Dim OutlookMail As Object
    Dim wb1 As Workbook
    Dim wb2 As Workbook
Dim Rng As Range
Set outlookApp = CreateObject("Outlook.Application")
Set OutlookMail = outlookApp.CreateItem(0)
Set Rng = [PrtArea]
Set wb1 = ActiveWorkbook


On Error Resume Next


OpenOutlook


TempFilePath = VBA.Environ$("temp") & "\"
    TempFileName = "Customer Complaint - " & ReplaceIllegalChar([LogNum]) & " - " & ReplaceIllegalChar([Complaint]) & " " & Format(Now, "mmddyy hhmm")
    FileExtStr = ".xlsm"
Filename = TempFilePath & TempFileName & FileExtStr


wb1.SaveCopyAs TempFilePath & TempFileName & FileExtStr
Set wb2 = Workbooks.Open(TempFilePath & TempFileName & FileExtStr)


With OutlookMail
    .To = [EmailTo].Value
    .CC = [EmailCC].Value
    .BCC = ""
    .Subject = "New Customer Complaint - " & [LogNum] & " - " & [Complaint]
    .HTMLBody = RangetoHTML(Rng)
    .Attachments.Add wb2.FullName
    .Display
End With
wb2.Close SaveChanges:=False


    ' Delete the file.
    Kill TempFilePath & TempFileName & FileExtStr
Set OutlookMail = Nothing
Set outlookApp = Nothing
End Sub
 

Excel Facts

Select all contiguous cells
Pressing Ctrl+* (asterisk) will select the "current region" - all contiguous cells in all directions.
An example:

Code:
Sub ExportPics()
Dim cht$, pic$, PicWidth&, PicHeight&, sht As Worksheet, i%, _
olApp As Outlook.Application, mi As MailItem, pt$
Application.ScreenUpdating = False
Set sht = ActiveSheet
Set olApp = CreateObject("Outlook.Application")
Set mi = olApp.CreateItem(0)
For i = 1 To sht.Shapes.Count
    pic = sht.Shapes(i).Name
    With sht.Shapes(i)
        PicHeight = .Height
        PicWidth = .Width
    End With
    Charts.Add
    ActiveChart.Location Where:=xlLocationAsObject, Name:="Sheet4"
    Selection.Border.LineStyle = 0
    cht = Selection.Name & " " & Split(ActiveChart.Name, " ")(2)
    With sht
        With .Shapes(cht)
            .Width = PicWidth
            .Height = PicHeight
        End With
        .Shapes(pic).Copy
        With ActiveChart
            .ChartArea.Select
            .Paste
        End With
        pt = ThisWorkbook.Path & "\MyPic" & i & ".jpg"
        .ChartObjects(1).Chart.Export pt, "jpg"         ' save to disk
        mi.Attachments.Add pt
        .Shapes(cht).Cut
    End With
Next
Application.ScreenUpdating = True
mi.Display
Set mi = Nothing
Set olApp = Nothing
End Sub
 
Upvote 0
Thanks for the (only) reply. The code returns with "The item with the specified name wasn't found when referring to the line
Code:
With .Shapes (cht)

Should it be pic instead?
 
Upvote 0
This being fixed I get an error on the line
Code:
 .ChartObjects(1).Chart.Export pt, "jpg"         ' save to disk
 
Upvote 0
  • This code creates a temporary chart, inserts the picture into it and saves it to disk. The resulting image is attached to the Outlook message. The code assumes you do not have any charts on that sheet.
  • I inserted some message boxes with relevant information. Tell me where the code stops, the error number and its description. It is working fine on my testing.



Code:
Sub ExportPics()
Dim cht$, pic$, PicWidth&, PicHeight&, sht As Worksheet, i%, _
olApp As Outlook.Application, mi As MailItem, pt$
Application.ScreenUpdating = False
Set sht = ActiveSheet
Set olApp = CreateObject("Outlook.Application")
Set mi = olApp.CreateItem(0)
MsgBox sht.Shapes.Count & " shapes on this sheet.", 64, sht.Name
For i = 1 To sht.Shapes.Count
    pic = sht.Shapes(i).Name
    MsgBox "Picture name: " & pic
    With sht.Shapes(i)
        PicHeight = .Height
        PicWidth = .Width
    End With
    Charts.Add
    ActiveChart.Location Where:=xlLocationAsObject, Name:="Sheet4"
    Selection.Border.LineStyle = 0
    cht = Selection.Name & " " & Split(ActiveChart.Name, " ")(2)
    MsgBox "Temporary chart name: " & cht
    With sht
        .Shapes(cht).Width = PicWidth
        .Shapes(cht).Height = PicHeight
        .Shapes(pic).Copy
        ActiveChart.ChartArea.Select
        ActiveChart.Paste
        pt = ThisWorkbook.Path & "\MyPic" & i & ".jpg"
        MsgBox "Exporting to " & pt
        .ChartObjects(1).Chart.Export pt, "jpg"         ' save to disk
        mi.Attachments.Add pt
        .Shapes(cht).Cut                                ' get rid of chart
    End With
Next
Application.ScreenUpdating = True
mi.Display
Set mi = Nothing
Set olApp = Nothing
End Sub
 
Upvote 0

Forum statistics

Threads
1,223,896
Messages
6,175,264
Members
452,627
Latest member
KitkatToby

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