Zoom in on an image (picture) displayed in workbook

[SerenityNetworks]

I'm using the following code to display an image in a workbook.

Sub Image21()
    On Error GoTo ProcExit21
    Dim objPicture As Picture
    With Sheets("Working").Cells(1, 1) ' Picture displays in cell from row, column
        Set objPicture = .Parent.Pictures.Insert(Sheets("Working").Cells(2, gvarImgColumn + 20).Value) ' Picture path row, column
        objPicture.Width = Sheets("Parameters").Cells(83, 2).Value
        'objPicture.Height = Sheets("Parameters").Cells(84, 2).Value
        objPicture.Top = Sheets("Parameters").Cells(85, 2).Value
        objPicture.Left = Sheets("Parameters").Cells(86, 2).Value
        objPicture.Border.Color = RGB(69, 107, 43)
        objPicture.Border.Weight = xlThick
        objPicture.Border.LineStyle = xlContinuous
    End With
ProcExit21:
End Sub

I would like to be able to zoom in on the image. I am not looking to simply make the image bigger; that I can do. I can control contrast and brightness for all images displayed, rotate a single image, and more, but I am not seeing how I can zoom in on a single image.

Is there a way?

Thanks in advance,
Andrew

 

[Yongle]

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

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

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

 

[SerenityNetworks]

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

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

 

[SerenityNetworks]

@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]

@Yongle

I just tried the crop idea by adding the crop line to the code below.

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]

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]

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)

 

[SerenityNetworks]

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

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

 

[Yongle]

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 - I cannot test at the moment

The sub in ThisWorkbook cannot be private

In a module

Sub Test()
    ThisWorkbook.Greet
End Sub

In ThisWorkbook

Sub Greet()
    MsgBox "Hello"
End Sub

 

[Yongle]

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

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

 

[SerenityNetworks]

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!