Как загрузить рисунок в ячейку excel и сохранить его в докумете

Question

Есть задача. Нужно загрузить изображение в ячейку excel. При этом его нужно сохранить в документе. С этим справляется Shapes.AddPicture(Paths, msoFlase). Но как его засунуть в нужную ячейку? Код ниже не работает. у меня бомбит......

Set img = ActiveCell.Shapes.AddPicture(Paths, msoFlase)

Answer 1

Подготавливаем почву:

Sub Main_Pictures()
    Dim rCell As Range              ' ячейка для вставки'
    Dim FolderPictures As String    ' путь к папке с рисунками'
    
    FolderPictures = ThisWorkbook.Path & "\pictures"
    If Dir(FolderPictures, vbDirectory) = "" Then MsgBox "Нет папки с рисунками", 64, "ОШИБКА": Exit Sub
    Set rCell = ActiveCell
    
    If MsgBox("Вставить рисунок?", 64 + vbYesNo, "") = vbNo Then Exit Sub
    
    Application.ScreenUpdating = False
    Call InsertPictures(rCell, FolderPictures)
    Application.ScreenUpdating = True
End Sub

Пример содержимого папки:

Функция поиска в папке нужного файла:

Function fPathPicture(FolderPictures As String, NamePicture As String) As String
    Dim FileName As String, s As String
    
    FileName = Dir(FolderPictures & "\*")

    Do While FileName <> ""
        s = Left$(FileName, InStrRev(FileName, ".") - 1)
        
        If s = NamePicture Then
            fPathPicture = FolderPictures & "\" & FileName
            Exit Function
        End If

        FileName = Dir
    Loop
End Function

Ячейки до обработки макросом:

Украшаем ячейку рисунком, имя которого указано в ячейке:

Sub InsertPictures(rCell As Range, FolderPictures As String)
    Dim oPic As Shape
    Dim PathPicture As String

    PathPicture = fPathPicture(FolderPictures, rCell.Value)
        
    If PathPicture <> "" Then
        Set oPic = rCell.Worksheet.Shapes.AddPicture(PathPicture, 0, 1, -1, -1, -1, -1)
        
        With oPic
            .Width = rCell.Width - 4
            .Height = rCell.Height - 4
                
            .Left = rCell.Left + 2
            .Top = rCell.Top + 2
        End With
    Else
        rCell.Value = rCell.Value & Chr$(10) & "нет картинки"
    End If
    
    Set oPic = Nothing
End Sub

Результат вставки (и попытки вставки) рисунков:

Если добавить цикл обхода ячеек, можно вставлять картинки массово (например, во вновь созданный прайс с миллионным заказом :) )

БЛОГ НА HUSL

Как загрузить рисунок в ячейку excel и сохранить его в докумете

Ответы (1 шт):