AddPicture need to reference cell for filepath and resize image

Question

I have an addpicture VBA that functions file with a fixed filepath but i need it to reference a filepath generated by a formula in a specific cell. also need to be able to resize the image to fit the cell column width but maintain aspect ratio. I was able to do all this with PictureInsert function but then the images are not visible when the document is used by other parties...

Here is my addpicture code:

Sub URLAddPicture()
    Set pic = ActiveSheet.Shapes.AddPicture("\\frb-fs01\DF\SHOEPICS\1. SHOE PHOTOS\spring summer 2020\BULK SAMPLES\DISCOVERY\AADLIA-SUBLACKEURO LEATHER.JPG", _
    linktofile:=msoFalse, savewithdocument:=msoCTrue, Left:=0, Top:=0, Width:=-1, Height:=-1)
End Sub

And PictureInsert code:

Sub URLPictureInsert()
    Dim Pshp As Shape
    Dim xRg As Range
    Dim xCol As Long

    On Error Resume Next

    Application.ScreenUpdating = False

    Set rng = ActiveSheet.Range("A113")
    For Each cell In rng
        filenam = cell
        ActiveSheet.Pictures.Insert(filenam).Select

        Set Pshp = Selection.ShapeRange.Item(1)
        If Pshp Is Nothing Then GoTo lab

        xCol = cell.Column
        Set xRg = Cells(cell.Row, xCol)
        With Selection
            .ShapeRange.LockAspectRatio = msoTrue
            If (.Height \ .Width) <= (rng.Height \ rng.Width) Then
                .Width = rng.Width - 1
                .Left = rng.Left + 1
                .Top = rng.Top + ((rng.Height - Selection.Height) / 2)
            Else
                .Top = rng.Top + 1
                .Height = rng.Height - 1
                .Left = rng.Left + ((rng.Width - Selection.Width) / 2)
            End If

            .Placement = xlMoveAndSize
            .PrintObject = True
        End With
lab:
        Set Pshp = Nothing
        Range("A113").Select
    Next

    Application.ScreenUpdating = True
End Sub

If anyone is able to assist I would be most grateful.

First of all the code cannot work because `If Pshp Is Nothing Then` has no `End If`. Also you must remove `On Error Resume Next` because this line hides **all** error messages until `End Sub`, so if you don't see your errors you cannot fix them and if you don't fix them obviously your code cannot work correctly. Fix that and then [edit] your question and tell which error you get and where. You might benefit reading [VBA Error Handling – A Complete Guide](https://excelmacromastery.com/vba-error-handling). — Pᴇʜ, Jan 22 '20 at 07:19
You might benefit from reading [How to avoid using Select in Excel VBA](https://stackoverflow.com/questions/10714251/how-to-avoid-using-select-in-excel-vba). Get rid of all `.Select` and `Selection` statements using the technique of this link. Then update the code in your question. • Also I recommend always to activate `Option Explicit`: In the VBA editor go to *Tools* › *Options* › *[Require Variable Declaration](https://www.excel-easy.com/vba/examples/option-explicit.html)* and declare all your variables properly. — Pᴇʜ, Jan 22 '20 at 07:20
Howto [resize](https://stackoverflow.com/a/53662026/9439330) and in addition to Pᴇʜ's suggestion, howto avoid [the-macro-recorder-curse/](https://rubberduckvba.wordpress.com/2019/06/30/the-macro-recorder-curse/) — ComputerVersteher, Jan 22 '20 at 07:24
@Davesexcel Meeehh, yes I didn't look properly, my bad. Thank's for pointing out. But that is actually a classic example why using `GoTo` or single line `If` statements are such a bad practice and such a bad coding style: Because it dosen't take long to result in an error. • My suggestion replace the `GoTo` with a multi line `If Not` satement `If Not Pshp Is Nothing Then` that ends with `End If` at `lab:` to get rid of it. — Pᴇʜ, Jan 22 '20 at 07:41
What is wrong with the `URLPictureInsert` code? How are other parties not able to see the picture? Is it because the filenames do not exist in A113 on other computers? — Davesexcel, Jan 22 '20 at 08:11
i recommend adressing the sheet by its real name instead of `activesheet`. `Set Pshp = ActiveSheet.Pictures.Insert(filenam).ShapeRange(1)` can also be used, to avoid `selection` , and it doesn't select the picture. please remove all the unnecessary `.select` — Patrick Lepelletier, Jan 22 '20 at 09:31
you need to copy the (jpg) of whatever format picture wich is on your computer's disk into the same file directory on the 'other partie's' computer — Patrick Lepelletier, Jan 22 '20 at 09:45

score 0 · Answer 1 · answered Jan 22 '20 at 09:50

If the pictures are on the right place on the hard drive (disk), and rng is right, this code should work. Also , no need to loop if rngis a single cell, but i kept it for later use if you make it bigger...

Option Explicit

Sub URLPictureInsert()
Dim Pshp As Shape
Dim Cell As Range
Dim Rng As Range
Dim Filenam$

Application.ScreenUpdating = False

Set Rng = ActiveSheet.Range("A113")

For Each Cell In Rng

    Filenam = Cell.Value2

    On Error Resume Next 'in case filename doesn't exist
    Set Pshp = ActiveSheet.Pictures.Insert(Filenam).ShapeRange(1)
    On Error GoTo 0

    If Not Pshp Is Nothing Then

          With Pshp

              .LockAspectRatio = msoTrue

              If (.Height \ .Width) <= (Rng.Height \ Rng.Width) Then
                  .Width = Rng.Width - 1
                  .Left = Rng.Left + 1
                  .Top = Rng.Top + ((Rng.Height - .Height) / 2)
              Else
                  .Top = Rng.Top + 1
                  .Height = Rng.Height - 1
                  .Left = Rng.Left + ((Rng.Width - .Width) / 2)
              End If

              .Placement = xlMoveAndSize

        End With 'Pshp

    End If 'not Pshp is nothing

    Set Pshp = Nothing

Next Cell

Application.ScreenUpdating = True
End Sub

AddPicture need to reference cell for filepath and resize image

1 Answers1