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