AddPicture нужно ссылаться на ячейку для пути к файлу и изменить размер изображения

Question

У меня есть addpicture VBA, который работает с файлом с фиксированным путем к файлу, но мне нужно, чтобы он ссылался на путь к файлу, сгенерированный формулой в указанной ячейке c. Также необходимо иметь возможность изменить размер изображения, чтобы соответствовать ширине столбца ячейки, но сохранить соотношение сторон. Я смог сделать все это с помощью функции PictureInsert, но тогда изображения не видны, когда документ используется другими сторонами ...

Вот мой код addpicture:

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

И 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

Если кто-нибудь сможет помочь, я был бы очень признателен.

Answer 1

Если изображения находятся в нужном месте на жестком диске (диске), а rng правильно, этот код должен работать. Кроме того, нет необходимости в l oop, если rng - одна ячейка, но я сохранил ее для дальнейшего использования, если вы увеличите ее ...

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