Excel Macro VBA - проверьте, находится ли изображение в ячейке - PullRequest
Новая
       21

Excel Macro VBA - проверьте, находится ли изображение в ячейке

0 голосов
/ 04 июля 2018

У меня есть макрос, который вставляет изображение в ячейку при нажатии на ячейку.

Когда вы нажимаете на изображение, на котором уже есть изображение, макрос повторяется, и в ячейке появляются 2 изображения.

Но я хочу ограничить это. Когда в ячейке уже есть изображение, макрос ничего не должен делать.

Как этого добиться? 

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Column = 20 Then
        Call Makro1
    End If
End Sub


Sub Makro1()
    On Error GoTo Ende

    Application.Cursor = xlWait
    ActiveSheet.Pictures.Insert( _
    ThisWorkbook.Path & "\Fotos\" & Range("A" & ActiveCell.Row).Value & ".jpg" _
      ).Select
    Selection.ShapeRange.ScaleWidth 0.28, msoFalse, msoScaleFromTopLeft
    Selection.ShapeRange.ScaleHeight 0.28, msoFalse, msoScaleFromTopLeft
    Selection.ShapeRange.LockAspectRatio = msoFalse
    Selection.ShapeRange.IncrementLeft 4
    Selection.ShapeRange.IncrementTop 4
    Selection.Placement = xlMoveAndSize
    ActiveSheet.Hyperlinks.Add Anchor:=Selection.ShapeRange.Item(1), Address:= _
      "Fotos\" & Range("A" & ActiveCell.Row).Value & ".jpg"
    Range("A1").Select
    Application.Cursor = xlDefault

Ende:
    Application.Cursor = xlDefault
End Sub

1 Ответ

0 голосов
/ 04 июля 2018

Вот код моего ответа. :) 

Function isImageInRange(Target As Range) As Boolean
    Dim pic As Picture
    Dim PictureRanges As Range

    With Target.Parent
        For Each pic In .Pictures
            With Range(pic.TopLeftCell, pic.BottomRightCell)
                If PictureRanges Is Nothing Then
                    Set PictureRanges = .Cells
                Else
                    Set PictureRanges = Union(PictureRanges, .Cells)
                End If
            End With
        Next
    End With

    If Not PictureRanges Is Nothing Then isImageInRange = Not Intersect(Target, PictureRanges) Is Nothing

End Function
...