Copy Pictures from worksheet and add as Outlook attachments

[DwinZly]

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:

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

 

[Worf]

An example:

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

 

[DwinZly]

Thanks for the (only) reply. The code returns with "The item with the specified name wasn't found when referring to the line

With .Shapes (cht)

Should it be pic instead?

 

[DwinZly]

This being fixed I get an error on the line

 .ChartObjects(1).Chart.Export pt, "jpg"         ' save to disk

 

[Worf]

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

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