Страницы: 1
RSS
Вставка рисунка в ячейку с удалением предыдущего рисунка, с небольшим отступом от краев.
 
Здравствуйте.
Подскажите как макросом - добавить рисунки в ячейки, где стоят значения "2" ?
В общем картинка там должна растянуться под ячейку, и должна остаться небольшая граница-отступ от краев ячейки.

В файле примере примерно изобразил, как картинка будет располагаться.
Адрес рисунка C:\Новый каталог\1.png
 
Например:
Код
Option Explicit

Const dostup$ = "C:\Temp\1.png" 'Vash dostup = papka i kartinka
Const strWhat = 2

Sub aaa()
Dim fnd, adrs$, dlin!, vys!, krtn

    With ActiveSheet.UsedRange
        Set fnd = .Find(What:=strWhat, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows)
        If Not fnd Is Nothing Then
            adrs = fnd.Address(0, 0)
            Do
                dlin = (fnd.Offset(0, 1).Left - fnd.Left) - 2.5
                vys = fnd.EntireRow.RowHeight - 2.5
                Set krtn = .Parent.Shapes.AddPicture(dostup, msoFalse, msoTrue, fnd.Left + 1.5, fnd.Top + 1.5, dlin, vys)
                krtn.Name = "Rys" & "_" & fnd.Address(0, 0)
                krtn.Placement = xlMoveAndSize
                krtn.ControlFormat.PrintObject = True
                Set krtn = Nothing
                Set fnd = .FindNext(fnd)
            Loop While Not fnd Is Nothing And fnd.Address(0, 0) <> adrs
        End If
    End With
End Sub
 
ocet p, подскажите, а как удалять картинки из ячеек со значением "2", перед каждым срабатыванием.
А то получается, что если несколько раз нажать на кнопку макроса - то картинки расположатся в несколько слоев.
 
Например:
Код
Option Explicit

Const dostup$ = "C:\Temp\1.png" 'Vash dostup = papka i kartinka
Const strWhat = 2

Sub aaa()
Dim fnd, adrs$, dlin!, vys!, krtn

    With ActiveSheet.UsedRange
    
        For Each krtn In .Parent.Shapes
            Select Case krtn.Type
                Case msoLinkedPicture, msoPicture: If krtn.Name Like "Rys_*" Then krtn.Delete
                Case Else: 'Net
            End Select
        Next
        
        Set fnd = .Find(What:=strWhat, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows)
        If Not fnd Is Nothing Then
            adrs = fnd.Address(0, 0)
            Do
                dlin = (fnd.Offset(0, 1).Left - fnd.Left) - 2.5
                vys = fnd.EntireRow.RowHeight - 2.5
                Set krtn = .Parent.Shapes.AddPicture(dostup, msoFalse, msoTrue, fnd.Left + 1.5, fnd.Top + 1.5, dlin, vys)
                krtn.Name = "Rys" & "_" & fnd.Address(0, 0)
                krtn.Placement = xlMoveAndSize
                krtn.ControlFormat.PrintObject = True
                Set krtn = Nothing
                Set fnd = .FindNext(fnd)
            Loop While Not fnd Is Nothing And fnd.Address(0, 0) <> adrs
        End If
    End With
End Sub
 
ocet p, большое вам спасибо.
Страницы: 1
Наверх