View Full Version : [SOLVED:] Is there any event which catches an image being pasted into a workbook?
EirikDaude
08-22-2014, 01:03 AM
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
08-22-2014, 02:26 AM
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
08-22-2014, 04:25 AM
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
08-22-2014, 05:37 AM
The intialisation code only runs when the workbook is activated, perhaps switching to another workbook and back again gets it to work?
EirikDaude
08-22-2014, 05:43 AM
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
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.