Photo Email

[bouncey]

H There, I have the following code that looks up a photo based on column A and places the photo in column L. The problem is when I email the file the photo's are not emailed. Is there any way to fix the photo's?

Private Sub Worksheet_Change(ByVal Target As Range)
 
Dim myPict As Picture
Dim PictureLoc As String
Dim lr As Long, r As Long
lr = Cells(Rows.Count, "A").End(xlUp).Row
 
ActiveSheet.Pictures.Delete
For r = 2 To lr
PictureLoc = "C\photography\" & Range("A" & r).Value & ".jpg"
 
With Range("l" & r)
    Set myPict = ActiveSheet.Pictures.AddPicture(PictureLoc)
    .RowHeight = 144
    myPict.Top = .Top
    myPict.Left = .Left
    myPict.Width = 110
    myPict.Height = 140
   
    
    myPict.Placement = xlMoveAndSize
End With
 
Next r
End Sub

Thanks in advance.

 

[Logit]

.
If you are open to using a different macro , this works here after emailing.

Option Explicit


Sub AddOlEObject()


    Dim mainWorkBook As Workbook
    Dim Folderpath, fStr, myPath, Filename As String
    Dim fso, NoOfFiles, listfiles, fls, strCompFilePath
    Dim counter
    
    Set mainWorkBook = ActiveWorkbook
    Sheets("Sheet1").Activate
    Folderpath = "C:\Users\My\Desktop\Pics"   '<-- Change path to your images here
    Set fso = CreateObject("Scripting.FileSystemObject")
    NoOfFiles = fso.GetFolder(Folderpath).Files.Count
    Set listfiles = fso.GetFolder(Folderpath).Files
    For Each fls In listfiles
       strCompFilePath = Folderpath & "\" & Trim(fls.Name)
        If strCompFilePath <> "" Then
        
            '// include image extensions here \\
            
            If (InStr(1, strCompFilePath, "jpg", vbTextCompare) > 1 _
            Or InStr(1, strCompFilePath, "jpeg", vbTextCompare) > 1 _
            Or InStr(1, strCompFilePath, "png", vbTextCompare) > 1) Then
                 counter = counter + 1
                 Filename = fls.Name
                    If InStr(Filename, ".") > 0 Then
                       Filename = Left(Filename, InStr(Filename, ".") - 1)
                    End If
                  Sheets("Sheet1").Range("A" & counter).Value = Filename
                  Sheets("Sheet1").Range("B" & counter).ColumnWidth = 25
                Sheets("Sheet1").Range("B" & counter).RowHeight = 100
                Sheets("Sheet1").Range("B" & counter).Activate
                Call insert(strCompFilePath, counter)
                Sheets("Sheet1").Activate
            End If
        End If
    Next
'mainWorkBook.Save




End Sub


Function insert(PicPath, counter)
'MsgBox PicPath
    With ActiveSheet.Pictures.insert(PicPath)
    
    '// change image sizes here \\
        
        With .ShapeRange
            .LockAspectRatio = msoTrue
            .Width = 50
            .Height = 70
        End With
        .Left = ActiveSheet.Range("B" & counter).Left
        .Top = ActiveSheet.Range("B" & counter).Top
        .Placement = 1
        .PrintObject = True
    End With
End Function

 

[bouncey]

I have tried your code but it is not bringing the photos through!

 

[Logit]

.
Be certain you edit the path to the location of your images :

[COLOR=#333333]Folderpath = "C:\Users\My\Desktop\Pics"   '<-- Change path to your images here[/COLOR]

My computer is named "My" and the images/photos I was working with were located on the desktop in a folder named "Pics".

You will need to edit the path to direct the macro to the location of your images.

 

[bouncey]

Thanks for that. I had changed the path.

 

[Logit]

.
Download example workbook : https://www.amazon.com/clouddrive/share/08p1xkikBCtLstWzybBykZsvASIEYXW5dxt2yliixlq

 

[bouncey]

thanks Logit - this works on a different basis to what I am trying to do. I need to enter a code in to a cell in column a which then looks up the correct photo and enter into column l. Your sheet enters all photos in the file.

 

[bouncey]

Hi,

Can anybody have a look at this for me please?

Thanks

 

[Logit]

.
I was re-reading your original post and finally realized I misunderstood your goal. Accept my apologies.

You want to copy images in a range and have them pasted to the body of an email. This macro will do that :

Option Explicit




Sub mailpicsorchart()
Dim OutApp As Object
Dim OutMail As Object
Dim vInspector, GetInspector, wEditor As Variant




Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
    .To = "yo momma@nowhere.com"
    .CC = "xyz@anc.com"
    .BCC = "abc@xyz.com"
    .Subject = "Test"
    .Body = "Dear" & "Macro " & vbCrLf
    .Display
    ActiveSheet.Range("K21:K26").Copy   '<-- range must cover all cells where pics are pasted
    Set vInspector = OutMail.GetInspector
    Set wEditor = vInspector.WordEditor


    wEditor.Application.Selection.Start = Len(.Body)
    wEditor.Application.Selection.End = wEditor.Application.Selection.Start


    wEditor.Application.Selection.Paste


.Display
End With
End Sub

Note the comment that the stated range in the macro must cover all cells where the images are pasted. You can include a column more on
either side of the pic/s and a column more above and below all the pic/s, it won't disrupt the process.

Hope I got it right this time.

 

[Logit]

.
bouncey

Did the code work for you ?