Is there a way to take a photo inside a cell and add it to an email?

[Firemonte]

Is there a way to take a photo inside a cell and add it to an email?

I know how to img src a file on the local drive or URL but is there a way that I can take a picture that resides inside a cell on a sheet and display it in the body of an email. I am using VB to generate the email.

 

[Logit]

Sub CopyCellAsImageAndEmail()
    Dim rng As Range
    Dim ws As Worksheet
    Dim filePath As String
    Dim emailApp As Object
    Dim emailItem As Object
    
    ' Set the active cell range
    Set rng = Selection
    Set ws = ActiveSheet
    
    ' Copy the cell as a picture
    rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    
    ' Create a temporary file path
    filePath = Environ("TEMP") & "\CellImage.jpg"
    
    ' Create a new chart to hold the picture
    Dim chartObj As ChartObject
    Set chartObj = ws.ChartObjects.Add(Left:=rng.Left, Top:=rng.Top, Width:=rng.Width, Height:=rng.Height)
    chartObj.Chart.Paste
    chartObj.Chart.Export Filename:=filePath, FilterName:="JPG"
    chartObj.Delete
    
    ' Create the email
    Set emailApp = CreateObject("Outlook.Application")
    Set emailItem = emailApp.CreateItem(0)
    
    With emailItem
        .To = "recipient@example.com"
        .Subject = "Cell Image"
        .Body = "Please find the attached image of the selected cell."
        .Attachments.Add filePath
        .Display ' Use .Send to send the email directly
    End With
    
    ' Clean up
    Set emailItem = Nothing
    Set emailApp = Nothing
End Sub

 

[Firemonte]

I like that. Thank you. As versus a selected range and sheet, I would like to have it set to a specific worksheet... ThisWorkbook.Sheets("Raw").Range("M2")

Thank you for helping a guy out that is relatively new at VB in excel.

 

[Firemonte]

Sub CopyCellAsImageAndEmail()
    Dim rng As Range
    Dim ws As Worksheet
    Dim filePath As String
    Dim emailApp As Object
    Dim emailItem As Object
   
    ' Set the active cell range
    Set rng = Selection
    Set ws = ActiveSheet
   
    ' Copy the cell as a picture
    rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
   
    ' Create a temporary file path
    filePath = Environ("TEMP") & "\CellImage.jpg"
   
    ' Create a new chart to hold the picture
    Dim chartObj As ChartObject
    Set chartObj = ws.ChartObjects.Add(Left:=rng.Left, Top:=rng.Top, Width:=rng.Width, Height:=rng.Height)
    chartObj.Chart.Paste
    chartObj.Chart.Export Filename:=filePath, FilterName:="JPG"
    chartObj.Delete
   
    ' Create the email
    Set emailApp = CreateObject("Outlook.Application")
    Set emailItem = emailApp.CreateItem(0)
   
    With emailItem
        .To = "recipient@example.com"
        .Subject = "Cell Image"
        .Body = "Please find the attached image of the selected cell."
        .Attachments.Add filePath
        .Display ' Use .Send to send the email directly
    End With
   
    ' Clean up
    Set emailItem = Nothing
    Set emailApp = Nothing
End Sub

Would it be possible to add in an /htmlbody as versus an attachment?

 

[Logit]

To always reference a specific sheet and cell :

Sub CopyCellAsImageAndEmail()
    Dim rng As Range
    Dim ws As Worksheet
    Dim filePath As String
    Dim emailApp As Object
    Dim emailItem As Object
    
    ' Reference the specific worksheet and cell
    Set ws = ThisWorkbook.Sheets("Raw")
    Set rng = ws.Range("M2")
    
    ' Copy the cell as a picture
    rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    
    ' Create a temporary file path
    filePath = Environ("TEMP") & "\CellImage.jpg"
    
    ' Create a new chart to hold the picture
    Dim chartObj As ChartObject
    Set chartObj = ws.ChartObjects.Add(Left:=rng.Left, Top:=rng.Top, Width:=rng.Width, Height:=rng.Height)
    chartObj.Chart.Paste
    chartObj.Chart.Export Filename:=filePath, FilterName:="JPG"
    chartObj.Delete
    
    ' Create the email
    Set emailApp = CreateObject("Outlook.Application")
    Set emailItem = emailApp.CreateItem(0)
    
    With emailItem
        .To = "recipient@example.com"
        .Subject = "Cell Image"
        .Body = "Please find the attached image of the specified cell."
        .Attachments.Add filePath
        .Display ' Use .Send to send the email directly
    End With
    
    ' Clean up
    Set emailItem = Nothing
    Set emailApp = Nothing
End Sub

For an HTML body you can try this :

Sub CopyCellAsImageAndEmail()
    Dim rng As Range
    Dim ws As Worksheet
    Dim filePath As String
    Dim emailApp As Object
    Dim emailItem As Object
    
    ' Reference the specific worksheet and cell
    Set ws = ThisWorkbook.Sheets("Raw")
    Set rng = ws.Range("M2")
    
    ' Copy the cell as a picture
    rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    
    ' Create a temporary file path
    filePath = Environ("TEMP") & "\CellImage.jpg"
    
    ' Create a new chart to hold the picture
    Dim chartObj As ChartObject
    Set chartObj = ws.ChartObjects.Add(Left:=rng.Left, Top:=rng.Top, Width:=rng.Width, Height:=rng.Height)
    chartObj.Chart.Paste
    chartObj.Chart.Export Filename:=filePath, FilterName:="JPG"
    chartObj.Delete
    
    ' Create the email
    Set emailApp = CreateObject("Outlook.Application")
    Set emailItem = emailApp.CreateItem(0)
    
    With emailItem
        .To = "recipient@example.com"
        .Subject = "Cell Image"
        ' Use HTMLBody to embed the image
        .HTMLBody = "<html><body>" & _
                    "Please find the image below:<br><br>" & _
                    "<img src='cid:CellImage'><br><br>" & _
                    "Best regards,<br>Your Name</body></html>"
        ' Attach the image as a linked resource
        .Attachments.Add filePath, 1, 0, "CellImage"
        .Display ' Use .Send to send the email directly
    End With
    
    ' Clean up
    Set emailItem = Nothing
    Set emailApp = Nothing
End Sub