Zoom in on an image (picture) displayed in workbook

Yongle

Well-known Member
Joined
Mar 11, 2015
Messages
5,258
Office Version
365
Platform
Windows
I wonder if this simple approach would work for you
- each time the user clicks on an image it keeps increasing in size
- use a trigger to reset after input to cell

Assign this same macro to each image
Code:
Sub ImageZoom()
    Const myZoom = [COLOR=#ff0000]1.5[/COLOR]
    With ActiveSheet.Shapes(Application.Caller)
        .Width = .Width * myZoom
        .ZOrder msoBringToFront
    End With
End Sub
This code could be behind a button or triggered after (specified ?)cells are edited etc
Code:
Sub ResetImageSizes()
'assumes all 4 shapes are same width
    Const W = [COLOR=#ff0000]145[/COLOR]
    Dim shp As Shape
    For Each shp In ActiveSheet.Shapes
        shp.Width = W
    Next
End Sub
 

Some videos you may like

Excel Facts

Repeat Last Command
Pressing F4 adds dollar signs when editing a formula. When not editing, F4 repeats last command.

SerenityNetworks

Board Regular
Joined
Aug 13, 2009
Messages
96
The following is provided for more detail on the image processing.

  • The macro provided earlier loads four local images onto the worksheet (not into a user form) in an area on the right of the worksheet.
  • The user types information regarding the images into cells (not a user form) visible on the left side of the worksheet.
  • The user clicks a button. The four images are removed.
  • The process repeats.
  • Currently...
    • If the user needs a better view of one of the images then the user clicks on the image. It expands to predefined dimensions on the right of the worksheet using the code below.
    • The user types information regarding the image into cells visible on the left side of the worksheet.
    • The user clicks a button. The images are removed.
    • The process repeats.
      • Ideally, the user would click and drag over the area they wish to examine. That area would then expand to fill the predefined area and persist while the user types information into worksheet cells. (It doesn't matter whether they click and drag over the initial presentation of the image or the expanded image.)
      • A zoom that persists while the user types information into cells is greatly preferred. I can live without the persist if needed, but it's not ideal.

Again, thank you. I'm pretty much lost as to how to accomplish this.

Andrew

Code:
Option Explicit
' The following subs are used to expand an image and bring to the front when it is clicked upon.  The code is placed in ThisWorkbook.
Private WithEvents cmbrs As CommandBars

Private Sub Workbook_Activate()
    Set cmbrs = Application.CommandBars
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    Set cmbrs = Application.CommandBars
End Sub

Private Sub cmbrs_OnUpdate()
    Call ManipulateImage
End Sub

Private Sub ManipulateImage()
    Dim shp As shape
    Dim wActiveCell As String
    Set shp = GetShape
    If Not shp Is Nothing Then
        wActiveCell = ActiveCell.Address
        Selection.ShapeRange.ZOrder msoBringToFront
        shp.Width = Sheets("Parameters").Cells(8, 6).Value
        shp.Top = Sheets("Parameters").Cells(6, 6).Value
        shp.Left = Sheets("Parameters").Cells(7, 6).Value
        'ActiveWindow.Zoom = 75 ' Sets zoom of worksheet window, not picture
        Range(wActiveCell).Select
        'MsgBox "Height = " & shp.Height & vbCr & "Width = " & shp.Width, vbOKOnly, shp.Name
        'If MsgBox("DELETE" & vbTab & shp.Name, vbYesNo, "Are you sure ?") = vbYes Then shp.delete
    End If
End Sub

Private Function GetShape() As shape
    Static oPreviousShp As shape
    Dim oCurrentShp As shape
    If TypeName(Selection) = "Picture" Then
        Set oCurrentShp = Application.Selection.ShapeRange.Item(1)
        If oPreviousShp Is oCurrentShp Then
            Set GetShape = Nothing
        Else
            Set oPreviousShp = oCurrentShp
            Set GetShape = oCurrentShp
        End If
    'Else
        'Set oPreviousShp = Nothing
    End If
End Function
 
Last edited:

SerenityNetworks

Board Regular
Joined
Aug 13, 2009
Messages
96
@Yongle

Sorry, the simple approach is much less than ideal. I've thought of doing that or something similar (such as simply expanding the image larger than I currently do when the user clicks on it).

The issue is that the image may need to be expanded to 4x, 6x, or more. This results in a huge image. The user then would need to scroll horizontally and vertically to find the area of interest. Memorize the information they need to log (prone to errors), then scroll back and enter the information.

I'd almost rather chip away at the image using the crop function. For example:
  • The image is 1920 x 1200.
  • Once expanded, it is displayed as 1000 x 625.
  • The user clicks the image (or a button) and the upper and left 10% of the image is cropped off (leaving an image 1728 x 1080).
  • The resulting image is displayed as 1000 x 625.
  • Each click crops off another 10% of the upper and left of the image.
    • 1728 x 1080 becomes 1555 x 972, which becomes 1400 x 875, which becomes 1260 x 787, and so on. All displayed as 1000 x 625.
Would something like the above be easy to implement? For my purposes, I believe it would work fine.
 

SerenityNetworks

Board Regular
Joined
Aug 13, 2009
Messages
96
@Yongle

I just tried the crop idea by adding the crop line to the code below.
Code:
Private Sub ManipulateImage()
    Dim shp As shape
    Dim wActiveCell As String
    Set shp = GetShape
    If Not shp Is Nothing Then
        wActiveCell = ActiveCell.Address
        Selection.ShapeRange.ZOrder msoBringToFront
        shp.PictureFormat.CropLeft = 500 'CROPPING TEST ------------------------------
        shp.Width = Sheets("Parameters").Cells(8, 6).Value
        shp.Top = Sheets("Parameters").Cells(6, 6).Value
        shp.Left = Sheets("Parameters").Cells(7, 6).Value
        Range(wActiveCell).Select
    End If
End Sub
It worked! However, it's not repeatable. No matter how many times I click on it, the crop remains at 500. I suspect I need to set a variable that increments

I'm thinking I could use two buttons. So...
  • Click an image and it expands
  • If that is not enough for the user to see the detail needed then...
    • User clicks a button to crop the upper and left 10% of the active image
    • If still not enough the user clicks the button again and so on until they have the image needed.
    • A second button could move the image back to its original position, so if needed the user could click on one of the other images and repeat the process.
      (As I mentioned, I'm not trying to save the altered images.)

Thoughts?
 

Yongle

Well-known Member
Joined
Mar 11, 2015
Messages
5,258
Office Version
365
Platform
Windows
Annoyingly I am committed for the next 48 hours , so cannot give your problem any concentrated focus until then.
- please keep updating the thread if you make any further progress
- on Monday I will look at eveything that you have posted and contribute further

In principle it looks like your idea should work :)

Good luck!
 

Yongle

Well-known Member
Joined
Mar 11, 2015
Messages
5,258
Office Version
365
Platform
Windows
Just a couple of question before I am called away
- what is your anticipation of maximum required enlargement of the cropped image ? (10 times, 20 times ? )
- are the dimensions of your images consistent or a random mix ?

And (a different train of thought)
- would you consider using a textbox (sitting above the enlarged image) to capture user text BEFORE that text is auto-pasted to the cell ?
(ie user drags the textbox around to allow him to keep his eyes on the image)
 
Last edited:

SerenityNetworks

Board Regular
Joined
Aug 13, 2009
Messages
96
To answer your questions:
  • I'm not sure on the max zoom. It could vary by project, but I'd think no greater than 10x.
  • The image dimensions vary wildly.
  • Yes, I'd consider using a textbox where the user could enter information while viewing the zoomed image.

But I've made progress using the crop functionality. The code is below. I simply cropped a little off the top and left of the image a little at a time. It works pretty well and will suffice as is. However, I would like to add functionality that would allow the user to trim off the right and bottom of the image when it is needed. (On occasion successive clicks move the region of interest to the upper right, but it's still not big enough to see what's needed. Cropping more off the right and/or bottom would further zoom the image.)

  • I'd make a couple of buttons to do it. However, the buttons would need to trigger a macro in ThisWorksheet. For the life of me, I can't figure out how to make that work. (I tried making a sub in a module that would call a function or sub in ThisWorksheet, but I could never get it to work.)
  • I'd thought since the left-mouse-click crops off the top and left that perhaps a right-mouse-click could crop off the right and bottom. But I don't know how to distinguish mouse buttons.

Thanks again,
Andrew

Code:
Option Explicit
Private WithEvents cmbrs As CommandBars

Public cropPerc As Long
Public wActiveCell As String

Private Sub Workbook_Activate()
    Set cmbrs = Application.CommandBars
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    Set cmbrs = Application.CommandBars
End Sub

Private Sub cmbrs_OnUpdate()
    Call ManipulateImage
End Sub

Private Sub ManipulateImage()
    Dim shp As shape
    Set shp = GetShape
    If Not shp Is Nothing Then
        wActiveCell = ActiveCell.Address
        Selection.ShapeRange.ZOrder msoBringToFront
        shp.Width = Sheets("Parameters").Cells(8, 6).Value
        shp.Top = Sheets("Parameters").Cells(6, 6).Value
        shp.Left = Sheets("Parameters").Cells(7, 6).Value
        Call CropImage(shp)
        Range(wActiveCell).Select
    End If
End Sub

Private Function GetShape() As shape
    Static oPreviousShp As shape
    Dim oCurrentShp As shape
    Dim shp As shape
    If TypeName(Selection) = "Picture" Then
        Set oCurrentShp = Application.Selection.ShapeRange.Item(1)
        Set shp = oCurrentShp
        If oPreviousShp Is oCurrentShp Then
            Set GetShape = Nothing
            Call CropImage(shp)
            Range(wActiveCell).Select
        Else
            Set oPreviousShp = oCurrentShp
            Set GetShape = oCurrentShp
            cropPerc = 0
        End If
    End If
End Function

Private Function CropImage(ByVal shp As shape)
'Sub CropImage(ByVal shp As shape)
        If Not shp Is Nothing Then
            If cropPerc < 75 Then
                'MsgBox "Height = " & shp.Height & vbCr & "Width = " & shp.Width & vbCr & "cropPerc = " & cropPerc, vbOKOnly, shp.Name
                shp.PictureFormat.CropLeft = shp.Width * cropPerc * 0.0175
                shp.PictureFormat.CropTop = shp.Height * cropPerc * 0.015
                Selection.ShapeRange.ZOrder msoBringToFront
                shp.Width = Sheets("Parameters").Cells(8, 6).Value
                shp.Top = Sheets("Parameters").Cells(6, 6).Value
                shp.Left = Sheets("Parameters").Cells(7, 6).Value
                cropPerc = cropPerc + 20
            End If
    End If
End Function
'End Sub
 
Last edited:

Yongle

Well-known Member
Joined
Mar 11, 2015
Messages
5,258
Office Version
365
Platform
Windows
I'd make a couple of buttons to do it. However, the buttons would need to trigger a macro in ThisWorksheet. For the life of me, I can't figure out how to make that work
From memory :eek: - I cannot test at the moment

The sub in ThisWorkbook cannot be private

In a module
Code:
Sub Test()
    ThisWorkbook.Greet
End Sub
In ThisWorkbook
Code:
Sub Greet()
    MsgBox "Hello"
End Sub
 
Last edited:

Yongle

Well-known Member
Joined
Mar 11, 2015
Messages
5,258
Office Version
365
Platform
Windows
I'd thought since the left-mouse-click crops off the top and left that perhaps a right-mouse-click could crop off the right and bottom. But I don't know how to distinguish mouse buttons.
??? again cannot test, but try this attempt at a workaround
- click on Yes when message box appears to crop left
- click on NO to crop from right

Code:
Private Function CropImage(ByVal shp As Shape)
        If Not shp Is Nothing Then
            If cropPerc < 75 Then
                If MsgBox("Left = YES", vbYesNo) = vbYes Then
                    shp.PictureFormat.CropLeft = shp.Width * cropPerc * 0.0175
                Else
                    shp.PictureFormat.CropRight = shp.Width * cropPerc * 0.0175
                End If
                    shp.PictureFormat.CropTop = shp.Height * cropPerc * 0.015
                    Selection.ShapeRange.ZOrder msoBringToFront
                    shp.Width = Sheets("Parameters").Cells(8, 6).Value
                    shp.Top = Sheets("Parameters").Cells(6, 6).Value
                    shp.Left = Sheets("Parameters").Cells(7, 6).Value
                    cropPerc = cropPerc + 20
            End If
    End If
End Function
 
Last edited:

SerenityNetworks

Board Regular
Joined
Aug 13, 2009
Messages
96
Ha! Both suggestions work great.

For the call from a module macro to a ThisWorkbook macro your method was the one I'd tried first. I must have had a typo' or made some other bonehead mistake, because it didn't work. So I tried "application.run...", "call...", "use..." and such - all without success.

With the yes/no method, it works fine too.

Now I just need to think it through and determine which method or combination of methods is going to be most useful (speedy) for the user.

Let me get back at it and I'll post back my results. It may be tomorrow night or Tuesday. I'm mostly booked today and I'll be at a customer site until late Monday.

Thanks again!
 

Forum statistics

Threads
1,089,471
Messages
5,408,445
Members
403,206
Latest member
DeB395

This Week's Hot Topics

  • help please
    SORRY NOT ANY GOOD AT EXCEL SO HELP WOULD BE MUCH APPRECIATED this formula is in a sheet called ignore...
  • two formulas needed
    Hello, I'll try my best to explain this: First formula needed in Sheet1 cell A2: If Sheet1 cell B2 = Sheet2 cell B2 then return a 1. If not then...
  • Dynamic Counts
    Good afternoon, we are tidying up some data & the data seems to be growing quicker than we are tidying it up! What we confirm (by reviewing it...
  • Help Excel formula eliminate duplicate values and keep only 2 identical rows.
    as picture below column A has a duplicate value. but the values are not the same as the rule. sometimes 4 rows, sometimes 10 rows or 7 or 9...
  • Macro Compile Error Sub or Function not defined
    Hello, I am trying to run macros from a validation list, all macros have been created and run perfectly on there own but I'm getting a compile...
  • Last row combined with Current Region VBA
    I'm generally happy finding the last row of data through something like Lastrow = Cells(Rows.Count, "D").End(xlUp) but I don't always receive data...
Top