Help With ActiveSheet.Shapes.AddPicture

Jasen79

New Member
Joined
Nov 25, 2020
Messages
47
Office Version
  1. 365
Platform
  1. Windows
  2. MacOS
Good Day, I am hoping one of you Brilliant coders can help me.

I have been trying to get this VDA code to work for months.

I have created a template for my office. On this template data is entered on one worksheet of the workbook. On the other the date from the cells is combined or moved to a printable/email sheet. My issue is when I need to email the form, The pictures that are associated with date are saved in folder. I need those pictures to be saved in the excel workbook. The code I have not works for looking up the pictures but will not save inside the workbook. Mr. Excel explained why this is and created a work around. But I can not get his work around to work with in my code. Can you please help?

VBA Code:
Sub InsertirPictures()
'
' Personal Note: Below file path needs to be changed to where the IR phots are located!!!
'
    Const fPath = "C:\Users\576186\Pictures\"
    Dim a As Variant, cel As Range, picPath As String
    'Coder Note:
    'The Arry is feed by changing data.
    'The sheet graps date from another cell on anther worksheet.
    'The whole workbook is used a a templete.
    'So the date is changing but the soures of the photos is not.
    'But the ptces in that loctaion change/are added.
    For Each a In Array("A38", "F38", "A54", "F54")
        Set cel = Range(a)
        picPath = fPath & cel.Value
        'I need to be able to save and email the form out with the pictures in them.
        If Not Dir(picPath, vbDirectory) = vbNullString Then
            'Want This ActiveSheet.Shapes.AddPicture
            With cel.Parent.Pictures.Insert(picPath)
             LinkToFile = msoFalse
                SaveWithDocument = msoTrue
                With .ShapeRange
                    .LockAspectRatio = msoFalse
                    .Width = 209
                    .Height = 209
                End With
                .Left = cel.Offset(, 0).Left
                .Top = cel.Offset(, 0).Top
            End With
        End If
    Next a
End Sub
 
Last edited by a moderator:

Excel Facts

Format cells as time
Select range and press Ctrl+Shift+2 to format cells as time. (Shift 2 is the @ sign).

yky

Well-known Member
Joined
Jun 7, 2011
Messages
1,873
Office Version
  1. 2010
Platform
  1. Windows
Try if this works for you.
VBA Code:
'Want This ActiveSheet.Shapes.AddPicture
If Not Dir(picPath, vbDirectory) = vbNullString Then

cel.parent.addpiture filename:=picpath, LinkToFile:= msoFalse, SaveWithDocument:= msoTrue, _
Top:= cel.Offset(, 0).Top, Left:= cel.Offset(, 0).Left, Width:=209, Height:=209

End If
 

Jasen79

New Member
Joined
Nov 25, 2020
Messages
47
Office Version
  1. 365
Platform
  1. Windows
  2. MacOS
Try if this works for you.
VBA Code:
'Want This ActiveSheet.Shapes.AddPicture
If Not Dir(picPath, vbDirectory) = vbNullString Then

cel.parent.addpiture filename:=picpath, LinkToFile:= msoFalse, SaveWithDocument:= msoTrue, _
Top:= cel.Offset(, 0).Top, Left:= cel.Offset(, 0).Left, Width:=209, Height:=209

End If
First, Thanks for replying so quickly! That really nice of you.
I don't think I filled it in correctly. Should it look like this?
VBA Code:
Sub InsertirPictures()
'
'
'
    Const fPath = "C:\Users\576186\Pictures\"
    Dim a As Variant, cel As Range, picPath As String
    
    For Each a In Array("A38", "F38", "A54", "F54")
        Set cel = Range(a)
        picPath = fPath & cel.Value
        'I need to be able to save and email the form out with the pictures in them.
        If Not Dir(picPath, vbDirectory) = vbNullString Then
            cel.Parent.addpiture Filename:=picPath, LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, _
                Top:=cel.Offset(, 0).Top, Left:=cel.Offset(, 0).Left, Width:=209, Height:=209
        End If
    Next a
End Sub
 

yky

Well-known Member
Joined
Jun 7, 2011
Messages
1,873
Office Version
  1. 2010
Platform
  1. Windows
Looks right. Does it work?
 

Jasen79

New Member
Joined
Nov 25, 2020
Messages
47
Office Version
  1. 365
Platform
  1. Windows
  2. MacOS

ADVERTISEMENT

Looks right. Does it work?
Besides the small spelling error (addpiture/addpicture), sadly it did not work. 😭
I have attached a link to the excel doc if you would like to take a closer look and see if you can get it to work from your end.
I really grateful for your help.
 
Last edited by a moderator:

RoryA

MrExcel MVP, Moderator
Joined
May 2, 2008
Messages
36,951
Office Version
  1. 365
  2. 2019
  3. 2016
  4. 2010
Platform
  1. Windows
  2. MacOS

ADVERTISEMENT

You would need cel.Worksheet.Shapes.addpicture rather than cel.Parent.addpiture
 
Solution

Jasen79

New Member
Joined
Nov 25, 2020
Messages
47
Office Version
  1. 365
Platform
  1. Windows
  2. MacOS
You would need cel.Worksheet.Shapes.addpicture rather than cel.Parent.addpiture
Yes, I saw that and tried. I am using my work PC and they would not let the extension be added.
 

RoryA

MrExcel MVP, Moderator
Joined
May 2, 2008
Messages
36,951
Office Version
  1. 365
  2. 2019
  3. 2016
  4. 2010
Platform
  1. Windows
  2. MacOS
I have no idea what that means, I'm afraid. What extension?
 

Watch MrExcel Video

Forum statistics

Threads
1,133,270
Messages
5,657,749
Members
418,411
Latest member
Excellency

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
Top