Create Excel Macro to insert picture based on file location in a cell

How do I create a macro that will go to sheet1 of my workbook and look at the location of a picture in Cell A1, and then insert the picture in Sheet 2 Cell A2?  

I created the following macro by recording for inserting a picture but i am unable to change the code to do what i want.

 ActiveSheet.Pictures.Insert( _
        "P:\Project_Files\Kentucky\KY14-041_KYTC_LaurelBA_11-1080\Images\Chelsey Pics 7-11-14\DSC00008.jpg" _
        ).Select
    Selection.ShapeRange.Width = 233.28

Seems like you can put the sheet1.range("A1") into the file location above but it does not work.

Thanks
thirdrockitAsked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Ejgil HedegaardCommented:
Here is a function to insert pictures.
Put it in a module.
The function has 2 arguments
Argument 1 = the cell to put the picture in, typically the cell with the formula.
Argument 2 = the picture path and name, a cell reference or a text.

With the picture path and name in Sheet1 A1
 P:\Project_Files\Kentucky\KY14-041_KYTC_LaurelBA_11-1080\Images\Chelsey Pics 7-11-14\DSC00008.jpg
The function to be put in A2 on Sheet2, pointing to the cell itself A2
=InsertPictureInCell(A2,Sheet1!A1)

Resize cell A2 on Sheet2 to hold the picture, as the function fits the picture to the cell size, keeping the aspect ratio.

If no file is found "No file" is displayed in the cell.
To insert a new picture, delete the existing first.
Press F2 to edit the formula, and Enter, or insert a new path and filename on Sheet1 to make the function run.
It is possible to copy the function to other cells.

Option Explicit

Function InsertPictureInCell(rg As Range, FilePathName As String) As String
Dim ws As Worksheet
Dim sh As Shape, objPicture As Object
Dim PictureExists As Integer
Dim PictureLeftPosition As Single, PictureTopPosition As Single
Dim PictureWidth As Single, PictureHeight As Single, Aspect As Single
    
    Application.ScreenUpdating = False
    Set ws = ThisWorkbook.Worksheets(rg.Worksheet.Name)
    PictureExists = 0
    If ws.Shapes.Count > 0 Then
        For Each sh In ws.Shapes
            If sh.TopLeftCell.Column = rg.Column And sh.TopLeftCell.Row = rg.Row Then
                PictureExists = 1
            End If
        Next sh
    End If
    If PictureExists = 0 Then
        If Dir(FilePathName) <> "" Then
            If LCase(Right(FilePathName, 3)) = "png" Or LCase(Right(FilePathName, 3)) = "tif" Then
                Set objPicture = ws.Pictures.Insert(FilePathName)
                Aspect = objPicture.Width / objPicture.Height
                objPicture.Delete
            Else
                Set objPicture = LoadPicture(FilePathName)
                Aspect = objPicture.Width / objPicture.Height
            End If
                
            PictureTopPosition = rg.Top + 1
            PictureLeftPosition = rg.Left + 1
            PictureHeight = rg.Height - 2
            PictureWidth = PictureHeight * Aspect
            ws.Shapes.AddPicture FilePathName, msoFalse, msoTrue, PictureLeftPosition, PictureTopPosition, PictureWidth, PictureHeight
            InsertPictureInCell = ""
        Else
            InsertPictureInCell = "No file"
        End If
    Else
        InsertPictureInCell = ""
    End If
    Application.ScreenUpdating = True
End Function

Open in new window

Insert-picture-function.xlsm
0
thirdrockitAuthor Commented:
My Excel sheet is only showing the picture name DSC00008.jpg so unless i convert it to the full project path "P:\Project_Files\Kentucky\KY14-041_KYTC_LaurelBA_11-1080\Images\Chelsey Pics 7-11-14\DSC00008.jpg", the function does not work.  Is there any way to get the function to work with just the file name (even though it is hyperlinked) ?  For some reason excel only shows the name and not the full path.  I guess another method would be an easy way to convert the hyperlinks to full path because when you insert a hyperlink, it automatically just puts the file name.
0
Ejgil HedegaardCommented:
Change the entire macro to this, then the file path is extracted from the hyperlink.

Option Explicit

Function InsertPictureInCell(rg As Range, rgFileHlink As Range) As String
Dim ws As Worksheet
Dim sh As Shape, objPicture As Object
Dim FilePathName As String
Dim PictureExists As Integer
Dim PictureLeftPosition As Single, PictureTopPosition As Single
Dim PictureWidth As Single, PictureHeight As Single, Aspect As Single
    
    FilePathName = rgFileHlink.Hyperlinks(1).Address
    
    Application.ScreenUpdating = False
    Set ws = ThisWorkbook.Worksheets(rg.Worksheet.Name)
    PictureExists = 0
    If ws.Shapes.Count > 0 Then
        For Each sh In ws.Shapes
            If sh.TopLeftCell.Column = rg.Column And sh.TopLeftCell.Row = rg.Row Then
                PictureExists = 1
            End If
        Next sh
    End If
    If PictureExists = 0 Then
        If Dir(FilePathName) <> "" Then
            If LCase(Right(FilePathName, 3)) = "png" Or LCase(Right(FilePathName, 3)) = "tif" Then
                Set objPicture = ws.Pictures.Insert(FilePathName)
                Aspect = objPicture.Width / objPicture.Height
                objPicture.Delete
            Else
                Set objPicture = LoadPicture(FilePathName)
                Aspect = objPicture.Width / objPicture.Height
            End If
                
            PictureTopPosition = rg.Top + 1
            PictureLeftPosition = rg.Left + 1
            PictureHeight = rg.Height - 2
            PictureWidth = PictureHeight * Aspect
            ws.Shapes.AddPicture FilePathName, msoFalse, msoTrue, PictureLeftPosition, PictureTopPosition, PictureWidth, PictureHeight
            InsertPictureInCell = ""
        Else
            InsertPictureInCell = "No file"
        End If
    Else
        InsertPictureInCell = ""
    End If
    Application.ScreenUpdating = True
End Function

Open in new window

0
Ultimate Tool Kit for Technology Solution Provider

Broken down into practical pointers and step-by-step instructions, the IT Service Excellence Tool Kit delivers expert advice for technology solution providers. Get your free copy now.

thirdrockitAuthor Commented:
Great!! That works.  Is there anyway to get the screen to refresh the pictures if i make a change to the Hyperlink?  Right now i am having to manual enter each picture (i have over 65) into a macro that will refresh the pic.  The code i am using is

 Range("B2").Select
    ActiveCell.FormulaR1C1 = _
        "=InsertPictureInCell(RC,'Landscape Photo Data'!RC[2])"

Sometimes i can do one pic, and the rest will change, but it doesn't do it everytime.  I have a macro that will delete all the pics on the page at one time. But you have to click the picture box, it F2, and press enter for each pic, or use the code above but still have to have it for every picture box.
0
thirdrockitAuthor Commented:
OK i figured it out.

Application.CalculateFullRebuild

Let me know if there is a better method but this does it.
0
Ejgil HedegaardCommented:
To make the formula calculate like other formulas, insert Application.Volatile as the first line after Function, and before the Dim statements. It must be the first statement in the function.
But changing a hyperlink does not force a recalculation.

To replace the existing picture replace line 9, PictureExists = 1 with sh.Delete.

I guess recalculation will be slow, to insert 65 pictures on every change on the worksheets.

So better just to change line 9 in the macro to always replace the picture, and not use Application.Volatile
Then press Ctrl+Alt+F9 to recalculate full.
To recalculate full and rebuild the keys are Ctrl+Alt+Shift+F9, but I don't think that is necessary.
Recalculate full and rebuild is equal to make all formulas again.
0
thirdrockitAuthor Commented:
OK, one more thing.  It is working great in Excel 2013.  But in Excel 2010, i get errors on the insert picture function for "no file" if i move a cell height or create a page break.  I can open it back in 2013 and it works fine.  Any idea to why it would do this?
0
Ejgil HedegaardCommented:
I use Excel 2007, no problem inserting or deleting page break, or changing row height.
After recalculate full, all update.

But I found a problem when there was no hyperlink, and made a revision for that.

To debug for the error, point at the first executable statement after the Dim's, press F9 to insert a break point.
Go to the cell with the error, press F2 to edit, and Enter, and the code stops at the break point.
Then use F8 to step the code, one line at a time, to see where the error occurs.
For a function you don't get any error messages, but the code terminate at that point.
Remove the break point again when done.

Option Explicit

Function InsertPictureInCell(rg As Range, rgFileHlink As Range) As String

Dim ws As Worksheet
Dim sh As Shape, objPicture As Object
Dim FilePathName As String
Dim PictureLeftPosition As Single, PictureTopPosition As Single
Dim PictureWidth As Single, PictureHeight As Single, Aspect As Single
    
    If rgFileHlink.Hyperlinks.Count > 0 Then
        FilePathName = rgFileHlink.Hyperlinks(1).Address
    Else
        FilePathName = ""
    End If
    
    Application.ScreenUpdating = False
    Set ws = ThisWorkbook.Worksheets(rg.Worksheet.Name)
    If ws.Shapes.Count > 0 Then
        For Each sh In ws.Shapes
            If sh.TopLeftCell.Column = rg.Column And sh.TopLeftCell.Row = rg.Row Then
                sh.Delete
            End If
        Next sh
    End If
    
    If FilePathName = "" Then
        InsertPictureInCell = "No hyperlink"
    Else
        If Dir(FilePathName) <> "" Then
            If LCase(Right(FilePathName, 3)) = "png" Or LCase(Right(FilePathName, 3)) = "tif" Then
                Set objPicture = ws.Pictures.Insert(FilePathName)
                Aspect = objPicture.Width / objPicture.Height
                objPicture.Delete
            Else
                Set objPicture = LoadPicture(FilePathName)
                Aspect = objPicture.Width / objPicture.Height
            End If
                
            PictureTopPosition = rg.Top + 1
            PictureLeftPosition = rg.Left + 1
            PictureHeight = rg.Height - 2
            PictureWidth = PictureHeight * Aspect
            ws.Shapes.AddPicture FilePathName, msoFalse, msoTrue, PictureLeftPosition, PictureTopPosition, PictureWidth, PictureHeight
            InsertPictureInCell = ""
        Else
            InsertPictureInCell = "No file"
        End If
    End If
    Application.ScreenUpdating = True
End Function

Open in new window

0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
thirdrockitAuthor Commented:
I tried to debug but didn't get an error. I have attached a screenshot of what is showing.  When i open the file, i can see all the pictures but i get a message that macros are disabled.  As soon as i enable the macros, the pictures disappear and no matter how many times i refresh or recreate the hyperlinks i get "no file" in the cells.  Again, works fine in excel 2013.screenshot.jpg
0
thirdrockitAuthor Commented:
When i put the stop code at line 30 "    If Dir(FilePathName) <> "" Then", then it skips straight to line 46 when i hit F8 to walk through the code
0
thirdrockitAuthor Commented:
One more note i have noticed.  If i use the last code you sent me, and open the file in excel 2010 and save it, it will also mess up when i open it in 2013 and i get "no file".  If i use the second code for hyperlinks that you sent me, it still messes up in 2010, but doesn't effect the file in 2013.  I am still able to make whatever changes i want and the code works great.  I have not clue what 2010 is does different.
0
Ejgil HedegaardCommented:
When the program continues on line 46 (else) then the Dir command can't find the file, so the result is "No file".
Hover the mouse over FilePathName when then program is in break mode.
But if the path is long, only part of it can be seen.
So try change "No file" to FilePathName in line 47, to display the file and path in the cell, just to see what the value is.
It works in Excel 2007 and 2013, so there must be something with the Dir command in Excel 2010.

I don't know what it is, and the only thing I can imagine is that something goes wrong with the path to the folder on drive P in Excel 2010.
Try hyperlink to a picture on C, to see if that works.
0
thirdrockitAuthor Commented:
The only thing it shows for file path is the picture number, so it would be for example "DSC00086.jpg".  And it does that in both the excel 2010 and excel 2013 versions.  Does the same thing when i move it to the c:\drive.
0
Ejgil HedegaardCommented:
Then it is not a problem with the Dir command.
The hyperlink is retrieved in line 12, but not the complete path, so Dir fails.
I tried changing line 45 instead, to display FilePathName = the hyperlink, in cells that work, and both Excel 2003 and 2007 displays the hyperlink with the path and filename.

It seems hyperlink addresses works differently in Excel 2010 and 2013.
But why it works in Excel 2013 and not in 2010 is strange, when the value is the same.

Guess you have to ask a new question to get somebody to look at that.
0
thirdrockitAuthor Commented:
I have reverted to upgrading everyone to 2013.  We have the licenses but at the time we upgraded 2013 was just being released.
0
thirdrockitAuthor Commented:
Hey Ejgil Hedegaard, just upgraded the 2 people using the script you have to 2013.  It works on one computer but the other computer gets "no file".  I am at a complete loss on why it would do this.  any suggestions on what else could be causing it?
0
Ejgil HedegaardCommented:
When the result is "No file", a hyperlink exists, but the address don't point to the picture file.
If it works on one computer the function do what is expected, so the fault must be elsewhere.

I don't know if there is a setting in Excel, how Excel handles hyperlinks.
Did you try edit the hyperlink in the session where it does not work, to see if that changes anything?

My path looks like this "..\..\..\..\Real path on the drive\Picture.jpg", so it looks like it is relative to the Excel file position, but when the Excel file is moved to another location, the path looks the same, and it works.

Is it possible to upload a sample file?

Or ask a new question, to get somebody to look at that.
They probably also would ask for a sample file.
0
thirdrockitAuthor Commented:
I have attached the file i am using.  Here is what i know that is going on.  I have 3 computers running excel 2013, mine included in the 3.  I can create the file below and do whatever i want to the file and the pictures come in great. If i open the file on any of the other computers (both windows 7, office 2013), i get "no file".  Then, if i open the file on my computer again, i get "no file"
insertpicturetest.xlsm
0
Ejgil HedegaardCommented:
When I edit some hyperlinks to point to pictures I have, press the Delete Pics button, and then Refresh, the pictures are inserted in the cells.

I have no clue to what is happening.
You must ask a new question, perhaps somebody has seen that before.
Did you try edit the hyperlink in the session where it does not work, to see if that changes anything?
If it works then, it could perhaps give somebody a hint to what the problem is.
0
thirdrockitAuthor Commented:
i have opened a new question to see what response i get.  I have noticed that it appears excel is losing the hyperlink through some process but im not sure how.  First of all, i use KUTOOLS to import the folder list that have the pictures as hyperlinks.  it creates a seperate sheet in my workgroup.  When i get "no file", i can create another sheet with the same hyperlinks, copy them to my page with the macro and somehow it refreshes everthing and starts working again.  But i am unable to use the sheet i previously created. Still at a loss.
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Excel

From novice to tech pro — start learning today.

Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.