Is there any event which catches an image being pasted into a workbook?

[EirikDaude]

Is there any event which catches an image being pasted into a workbook? From quite a lot of googling, I suspect no, could someone give me some pointers of how I'd build a custom function which does this? Basically I want every image I paste into a worksheet to be automatically resized and compressed, but no event I've tried has been able to notice the paste, so I am kind of stuck

[Jan Karel Pieterse]

You could write a small macro which you tie to a short-cut key to do the paste and then the resize and compress?

[EirikDaude]

I tried putting this in ThisWorkbook

Option Explicit

Private Sub Workbook_Activate()
  Application.OnKey "^v", "resizeImage"
End Sub

Private Sub Workbook_Deactivate()
  Application.OnKey "^v"
End Sub

and this in a standard module:

Sub resizeImage()
  Dim r As Range, pos As Long, o As Object
  
  ActiveSheet.Paste
  Set o = Selection
  Debug.Print ("Test 1")
  If TypeName(o) <> "Range" Then
    Debug.Print ("Test 2")
    If o.ShapeRange.Width >= 185.6 Then
      Debug.Print ("Test 3")
      o.ShapeRange.Height = 185.6
    End If
    If o.ShapeRange.Height > 155# Then
      Debug.Print ("Test 4")
      o.ShapeRange.Height = 155#
    End If
  End If
End Sub

but apparently I am doing something wrong, as the resizing doesn't take place...

[Jan Karel Pieterse]

The intialisation code only runs when the workbook is activated, perhaps switching to another workbook and back again gets it to work?

[EirikDaude]

That did it! Thanks a ton for your help!

- edit - Added the rest of the code for the formatting, in case anyone's interested. If anyone has suggestions for better implementation, please let me know.

The .offset(1,0).offset(-1,0) is to get the entire range of some merged cells. A better solution would probably be to just reformat the worksheet I was given to not use merged cells, but eh...

Option Explicit

Sub resizeImage()
  Dim r As Range, pos As Long, o As Object
  Dim octl As CommandBarControl
  
  Set r = Range(ActiveCell, ActiveCell.Offset(1, 0).Offset(-1, 0))
  
  ActiveSheet.Paste
  Set o = Selection
  If TypeName(o) <> "Range" Then
    If o.ShapeRange.Width > 185.6 Then
      o.ShapeRange.Width = 185.6
    End If
    If o.ShapeRange.Height > 155# Then
      o.ShapeRange.Height = 155#
    End If
    Set octl = Application.CommandBars.FindControl(ID:=6382)
    Application.SendKeys "%e~"
    Application.SendKeys "%a~"
    octl.Execute
    Call centerMe(o, r)
  End If
End Sub

Sub centerMe(obj As Object, overCells As Range)
  With overCells
    obj.Left = .Left + ((.Width - obj.Width) / 2)
    obj.Top = .Top + ((.Height - obj.Height) / 2)
  End With
End Sub