Код VBA: вставка изображения в ячейку на основе URL-адреса, введенного в форму

Question

Я закодировал форму для ввода информации о продукте, которая позволяет пользователю просматривать местоположение файла и вставляет это местоположение в ячейку на листе после отправки. Я хотел бы закодировать из так, чтобы более поздняя ячейка отображала файл изображения. Я нашел ресурс fantasti c, в котором есть код, который делает то, что я хочу. Ресурс находится по следующей ссылке: https://techcommunity.microsoft.com/t5/excel/convert-image-url-to-actual-image-in-excel/m-p/309020

Проблема заключается в том, что после запуска кода он обновляет все ссылки на листе, создавая повторяющиеся изображения в стопке. Я хотел бы изменить и добавить код в код формы, чтобы при отправке формы добавлялся только новый URL-адрес изображения.

Вот код, найденный по ссылке выше:

Sub URLPictureInsert()
'Updateby Extendoffice 20161116
'Update #1 by Haytham Amairah in 20180104
'Update #2 by Haytham Amairah in 20180108

    Dim Pshp As Shape
    Dim xRg As Range
    Dim xCol As Long
    On Error Resume Next
    Application.ScreenUpdating = False
    Set Rng = ActiveSheet.Range("A2:A140")
    For Each cell In Rng
        filenam = cell
        ActiveSheet.Pictures.Insert(filenam).Select
        Set Pshp = Selection.ShapeRange.Item(1)
        Pshp.Placement = xlMoveAndSize
        If Pshp Is Nothing Then GoTo lab
        xCol = cell.Column + 1
        Set xRg = Cells(cell.Row, xCol)
        With Pshp
            .LockAspectRatio = msoFalse
            .Width = 60
           .Height = 30
            .Top = xRg.Top + (xRg.Height - .Height) / 2
            .Left = xRg.Left + (xRg.Width - .Width) / 2
        End With
lab:
    Set Pshp = Nothing
    Range("A2").Select
    Next
    Application.ScreenUpdating = True
End Sub

Вот фрагмент кода, который у меня сейчас есть, к которому я хотел бы добавить приведенный выше код:

Dim ComputerId As String
ComputerId = Environ$("ComputerName")
Dim Specs_Number As String
Specs_Number = Left(Me.ComboBoxSpecification.Value, Application.Find(" - ", Me.ComboBoxSpecification.Value) - 1)
Dim Specs_Name As String
Specs_Name = Right(Me.ComboBoxSpecification.Value, (Len(Me.ComboBoxSpecification.Value) - 2) - Application.Find(" - ", Me.ComboBoxSpecification.Value))
Dim RowCount As Long
RowCount = Worksheets("FormData").Range("A1").CurrentRegion.Rows.Count

Select Case Me.ComboBoxDivision
Case "DIVISION 22 - PLUMBING"
Set ws = Sheets("Div-22")

Case "DIVISION 23 - HEATING VENTILATING AND AIR CONDITIONING"
Set ws = Sheets("Div-23")


LastRow = ws.Range("C" & Rows.Count).End(xlUp).Row + 1
ws.Range("b" & LastRow).Value = Specs_Number
ws.Range("c" & LastRow).Value = Specs_Name
AddLink ws.Range("i" & LastRow), Me.TextBoxPicture_File_Link.Value
ws.Range("o" & LastRow).Value = Me.TextBoxSales_Rep_Email.Value

Unload Product_Information_Form
Start_Form.Show

End Sub

А вот пример того, что я хотел бы (нижняя половина кода, " ws.Range ("r" & LastRow) .Value = URLPictureInsert () "строка кода):

Dim ComputerId As String
ComputerId = Environ$("ComputerName")
Dim Specs_Number As String
Specs_Number = Left(Me.ComboBoxSpecification.Value, Application.Find(" - ", Me.ComboBoxSpecification.Value) - 1)
Dim Specs_Name As String
Specs_Name = Right(Me.ComboBoxSpecification.Value, (Len(Me.ComboBoxSpecification.Value) - 2) - Application.Find(" - ", Me.ComboBoxSpecification.Value))
Dim RowCount As Long
RowCount = Worksheets("FormData").Range("A1").CurrentRegion.Rows.Count

Select Case Me.ComboBoxDivision
Case "DIVISION 22 - PLUMBING"
Set ws = Sheets("Div-22")

Case "DIVISION 23 - HEATING VENTILATING AND AIR CONDITIONING"
Set ws = Sheets("Div-23")

LastRow = ws.Range("C" & Rows.Count).End(xlUp).Row + 1
ws.Range("b" & LastRow).Value = Specs_Number
ws.Range("c" & LastRow).Value = Specs_Name
AddLink ws.Range("i" & LastRow), Me.TextBoxPicture_File_Link.Value
ws.Range("o" & LastRow).Value = Me.TextBoxSales_Rep_Email.Value


ws.Range("r" & LastRow).Value = URLPictureInsert()


Unload Product_Information_Form
Start_Form.Show

End Sub

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("J2:J140")
    For Each cell In Rng
        filenam = cell
        ActiveSheet.Pictures.Insert(filenam).Select
        Set Pshp = Selection.ShapeRange.Item(1)
        Pshp.Placement = xlMoveAndSize
        If Pshp Is Nothing Then GoTo lab
        xCol = cell.Column + 1
        Set xRg = Cells(cell.Row, xCol)
        With Pshp
            .LockAspectRatio = msoFalse
            .Width = 60
            .Height = 60
            .Top = xRg.Top + (xRg.Height - .Height) / 3
            .Left = xRg.Left + (xRg.Width - .Width) / 3
        End With
lab:
    Set Pshp = Nothing
    Range("J2").Select
    Next
    Application.ScreenUpdating = True
End Sub

Любая помощь приветствуется. Если возможно, объясните, пожалуйста, ясным и подробным образом, так как я все еще новичок в кодировании VBA и новичок в кодировании в целом.

Answer 1

Вот простая демонстрация вызова подпрограммы для вставки изображения с заданного URL-адреса в указанное c местоположение.

Вы можете позвонить URLPictureInsert из своего кода и передать ему ячейку с URL-адресом. и ячейка, в которой изображение должно go.

Sub Tester()
    'get an image URL from A3 and put the image at C3
    URLPictureInsert Range("a3"), Range("C3")

End Sub



Sub URLPictureInsert(rngURL As Range, rngWhere As Range)

    Dim shp As Shape

    On Error Resume Next

    Set shp = rngWhere.Parent.Shapes.AddPicture(rngURL.Value, LinkToFile:=msoFalse, _
              SaveWithDocument:=msoTrue, Left:=rngWhere.Left, Top:=rngWhere.Top, _
              Width:=-1, Height:=-1)

    On Error GoTo 0

    If Not shp Is Nothing Then
        shp.Width = 30
        shp.Height = 30
    End If

End Sub