Enlarge image when clicked or moused over

S

shadydeals

New Member
Joined
Jun 17, 2008
Messages
22
hi - i have a whole bunch of thumbnail sized images in an excel sheet that are placed there by a third party application (so if they are saved on my hard drive, i do not know the path).

i would like to have some way to click or mouse over them and enlarge them for viewing.

i considered creating a user form to copy and view the image or just writing some VBA to resize the image when it is selected and putting it back when deselected.

I'm guessing someone has done this before, but i haven't found quite what i am looking for in the forums. any help would be appreciated.

thanks.
 

Excel Facts

Difference between two dates
Secret function! Use =DATEDIF(A2,B2,"Y")&" years"&=DATEDIF(A2,B2,"YM")&" months"&=DATEDIF(A2,B2,"MD")&" days"
Sort by date Sort by votes
Hi, Try this code:-
After loading Code in sheet Module, Click Cell to Right of Image, Image should enlarge, Click anywhere in column "A", Image should Reduce in size.
Change Image sizes Large (100) and small (30) in code.
Code: 
Private [COLOR=navy]Sub[/COLOR] Worksheet_SelectionChange(ByVal Target [COLOR=navy]As[/COLOR] Range)
[COLOR=navy]Dim[/COLOR] oSt [COLOR=navy]As[/COLOR] Range, opic [COLOR=navy]As[/COLOR] Shape
[COLOR=navy]If[/COLOR] Target.Column > 1 [COLOR=navy]Then[/COLOR]
    [COLOR=navy]Set[/COLOR] oSt = Target.Offset(, -1)
        [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] opic [COLOR=navy]In[/COLOR] ActiveSheet.Shapes
            [COLOR=navy]If[/COLOR] TypeName(opic.OLEFormat.Object) = "Picture" [COLOR=navy]Then[/COLOR]
                [COLOR=navy]If[/COLOR] opic.TopLeftCell.Address = oSt.Address [COLOR=navy]Then[/COLOR]
                    opic.Height = 250
                    opic.Width = 250
                [COLOR=navy]End[/COLOR] If
            [COLOR=navy]End[/COLOR] If
        [COLOR=navy]Next[/COLOR] opic
[COLOR=navy]ElseIf[/COLOR] Target.Column = 1 [COLOR=navy]Then[/COLOR]
    [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] opic [COLOR=navy]In[/COLOR] ActiveSheet.Shapes
       [COLOR=navy]If[/COLOR] TypeName(opic.OLEFormat.Object) = "Picture" [COLOR=navy]Then[/COLOR]
            opic.Height = 30
            opic.Width = 30
       [COLOR=navy]End[/COLOR] If
   [COLOR=navy]Next[/COLOR] opic
[COLOR=navy]End[/COLOR] [COLOR=navy]If[/COLOR]
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]
Regards Mick
 
Upvote 0
thanks! that was a great starting point for me... i was able to do exactly what i wanted. just in case if helps future people, here is what i did... basically, instead of the cell reference, i just assigned macros to each picture and enlarged the one clicked (or deleted it if it was over a certain size).

thanks again.

Code: 
Sub ResizeShapes()
Dim oSt As Range, opic As Shape

Dim tname As String

Application.ScreenUpdating = False
tname = ActiveSheet.Shapes(Application.Caller).Name
'tname = Selection.Name

If Selection.Height > 499 Then
Selection.Delete
End If


For Each opic In ActiveSheet.Shapes
       If opic.Name = "dupshape" Then
            opic.Delete
        End If
Next opic


For Each opic In ActiveSheet.Shapes

        If opic.Name = tname Then
            opic.Duplicate.Name = "dupshape"
        Else
         
        End If
Next opic

For Each opic In ActiveSheet.Shapes
    If opic.Name = "dupshape" Then
        opic.Height = 500
        opic.Width = 800
        opic.Select
        Selection.OnAction = "ResizeShapes"
        opic.Left = 10
        opic.Top = 10
    End If
Next opic
Application.ScreenUpdating = True

End Sub
 
Upvote 0
Hi MickG,

I was just wondering if it is possible to modify your code to run from another sheet / have the cell references in a second sheet... ie Sheet 1 holds the image and sheet 2 has 2 cells/buttons that cause the zoom in/out which is then viewed through a linked image. I've reasonable experience with Excel but really none with VB. Currently using Excel 2010 & 2013.

By the way really nice little affect!

Regards

Tui
 
Upvote 0
MickG said:
Hi, Try this code:-
After loading Code in sheet Module, Click Cell to Right of Image, Image should enlarge, Click anywhere in column "A", Image should Reduce in size.
Change Image sizes Large (100) and small (30) in code.
Code: 
Private [COLOR=navy]Sub[/COLOR] Worksheet_SelectionChange(ByVal Target [COLOR=navy]As[/COLOR] Range)
[COLOR=navy]Dim[/COLOR] oSt [COLOR=navy]As[/COLOR] Range, opic [COLOR=navy]As[/COLOR] Shape
[COLOR=navy]If[/COLOR] Target.Column > 1 [COLOR=navy]Then[/COLOR]
    [COLOR=navy]Set[/COLOR] oSt = Target.Offset(, -1)
        [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] opic [COLOR=navy]In[/COLOR] ActiveSheet.Shapes
            [COLOR=navy]If[/COLOR] TypeName(opic.OLEFormat.Object) = "Picture" [COLOR=navy]Then[/COLOR]
                [COLOR=navy]If[/COLOR] opic.TopLeftCell.Address = oSt.Address [COLOR=navy]Then[/COLOR]
                    opic.Height = 250
                    opic.Width = 250
                [COLOR=navy]End[/COLOR] If
            [COLOR=navy]End[/COLOR] If
        [COLOR=navy]Next[/COLOR] opic
[COLOR=navy]ElseIf[/COLOR] Target.Column = 1 [COLOR=navy]Then[/COLOR]
    [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] opic [COLOR=navy]In[/COLOR] ActiveSheet.Shapes
       [COLOR=navy]If[/COLOR] TypeName(opic.OLEFormat.Object) = "Picture" [COLOR=navy]Then[/COLOR]
            opic.Height = 30
            opic.Width = 30
       [COLOR=navy]End[/COLOR] If
   [COLOR=navy]Next[/COLOR] opic
[COLOR=navy]End[/COLOR] [COLOR=navy]If[/COLOR]
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]
Regards Mick
Click to expand...

Hi MickG,

Is there a way to change this code so that it activates and deactivates via mouse hover instead of select?

I have a series of small images of charts taken via the Camera tool, and I want these images to enlarge when a user simply hovers over the image.

Thanks,

Matty
 
Upvote 0
I think a "Click Event " is all you can get:-
This code will Enlarge and return to original size on "Click"
Place this in your Picture code module, Change "Picture3" to you Picture name.
Code: 
Option Explicit
[COLOR="Navy"]Dim[/COLOR] fd [COLOR="Navy"]As[/COLOR] Boolean
[COLOR="Navy"]Sub[/COLOR] Picture3_Click()
fd = fd Xor True
[COLOR="Navy"]With[/COLOR] ActiveSheet.Shapes(Application.Caller).OLEFormat.Object
    [COLOR="Navy"]If[/COLOR] fd [COLOR="Navy"]Then[/COLOR]
        .Width = .Width + 50
        .Height = .Height + 50
    [COLOR="Navy"]Else[/COLOR]
        .Width = .Width - 50
        .Height = .Height - 50
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
Thanks Mick. That works well.

Is there a way to change it so that the enlarge happens from top right to bottom left instead of the top left to bottom right?

Thanks,

Matty
 
Upvote 0
Additionally, is it possible that if the enlarged picture overlaps another picture, the enlarged picture comes to the front rather than at the back?

Thanks,

Matty
 
Upvote 0
Try this:-
Code: 
Option Explicit
Dim fd As Boolean
Sub Picture3_Click()
fd = fd Xor True
With ActiveSheet.Shapes(Application.Caller).OLEFormat.Object
    If fd Then
        .Left = .Left - 50
        .Width = .Width + 50
        .Top = .Top - 50
        .Height = .Height + 50
    Else
        .Left = .Left + 50
        .Width = .Width - 50
        .Top = .Top + 50
        .Height = .Height - 50
    End If
   .ShapeRange.ZOrder msoBringToFront
End With
End Sub
 
Upvote 0
MickG said:
Try this:-
Code: 
Option Explicit
Dim fd As Boolean
Sub Picture3_Click()
fd = fd Xor True
With ActiveSheet.Shapes(Application.Caller).OLEFormat.Object
    If fd Then
        .Left = .Left - 50
        .Width = .Width + 50
        .Top = .Top - 50
        .Height = .Height + 50
    Else
        .Left = .Left + 50
        .Width = .Width - 50
        .Top = .Top + 50
        .Height = .Height - 50
    End If
   .ShapeRange.ZOrder msoBringToFront
End With
End Sub
Click to expand...

Thanks. That looks like it will do the trick.

Cheers,

Matty
 
Upvote 0
You must log in or register to reply here.

Similar threads

zookeepertx
  • Solved
Weird Excel quirks driving me crazy! Can anyone explain?
Replies
5
Views
146
zookeepertx
zookeepertx
R
  • Question
VBA Performance / Optimization & Out of Memory Error
Replies
9
Views
666
Candyman8019
C
M
  • Solved
VBA Label Font goes Bold and Underline when moving mouse over
Replies
4
Views
1K
Domenic
D
A
  • Question
Show Data Validation Lists in Next Row of Table
Replies
0
Views
435
AndyPandy27
A
C
  • Question
Can't open a downloaded XLS file in Excel, but I can in Excel for the web - what am I doing wrong?!
Replies
3
Views
1K
Joe4
Joe4

Forum statistics

Threads
1,214,945
Messages
6,122,395
Members
449,081
Latest member
JAMES KECULAH

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top