Inserting and resizing pics

stltom554

New Member
Joined
Aug 1, 2015
Messages
27
I will apologize up front. I am not a VBA guy. I have modified some code in the past but even with what I am finding here I can't seem to put it all together.

What I have is a site survey where techs need to add pictures into one particular sheet. I need to accomplish the following:

  1. Import the picture to a specific cell (Ideally I would like to hide the button in the cell and click on the open cell which would keep it looking clean.
  2. Automatically size the photo to the same size as the cell
  3. Automatically add code/macro to the photo upon import which will allow the end user (customer) to click on the picture when reviewing the survey, and it pops up to it's original size in the middle of the screen, and another click to bring it back down.

Some of my problem may arise from me using the developer tools on my Mac. I am not sure.

Thank you in advance for your assistance[TABLE="width: 1173"]
<colgroup><col><col><col></colgroup><tbody>[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD] [/TD]
[/TR]
[TR]
[TD]Perspective Photo of Outside MPOE (leading into)[/TD]
[TD] [/TD]
[TD] [/TD]
[/TR]
[TR]
[TD]MPOE Room Perspectives (take a few if possible)[/TD]
[TD] [/TD]
[TD] [/TD]
[/TR]
</tbody>[/TABLE]
 
With respect to your comment:
"Cannot run the macro "TogglePict'. The macros may not be available in this workbook or all macros might be disabled"

In Windows code in a standard module is available to all worksheets and other code
in the project, unless the sub or function is defined as a Private Sub or Private Function
InsertPictureIntoSelectedCell' and 'TogglePict' should be in a standard module and so should be
available to all code.
I do not know if the Mac standard module works the same way, but I would be surprised if not.

I modified the code and added some. Please let me know if you have questions or if the code is still not running correctly.

Code:
Option Explicit
'https://www.mrexcel.com/forum/excel-questions/1039443-inserting-resizing-pics.html

'=========================================================================
'If you will never use a UNC path, this block of text is not required
'This allows the program to accept a Window UNC path in the ChDir function
'    Window UNC path is similar to: \\Server\Directory\SubDirectory
'    Instead of only understanding a reference to a mapped letter drive:
'        C:\Directory\SubDirectory
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  Win64 Then ' Win64    other option would be if VBA7
    Private Declare PtrSafe Function SetCurrentDirectoryA Lib "kernel32" _
        (ByVal lpPathName As String) As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL]  ' Downlevel when using previous version of VBA7
    Private Declare Function SetCurrentDirectoryA Lib "kernel32" _
        (ByVal lpPathName As String) As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
'=========================================================================

Const bKeepPixAspectRatio As Boolean = True 'Shrunk pictures keep aspect ratio if True

'Add the Private Sub below to all worksheets where you want to insert pictures
'When a cell is right-clicked the code to insert a photo will be triggered
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
    InsertPictureIntoSelectedCell
End Sub
'End Add the Private Sub

Sub InsertPictureIntoSelectedCell()
    'Assumes original picture size is larger than the cell size
    'Assumes original aspect ration should be retained
    
    Dim sCellAddr As String
    Dim sngCellHeight As Single
    Dim sngCellWidth As Single
    Dim sngPixHeight As Single
    Dim sngPixWidth As Single
    Dim sFilePathNameExt As String
    Dim sFilePath As String
    Dim sFileNameExt As String
    
    'Only a single cell can be double-clicked on at a time
    If Selection.Cells.Count > 1 Then
        MsgBox "Select the single cell where the picture will be inserted.", , "Select 1 Cell"
        GoTo End_Sub
    End If
    
    'Get dimensions & and address of the cell that was clicked on
    sngCellHeight = Selection.Height
    sngCellWidth = Selection.Width
    sCellAddr = Selection.Address(False, False)
    
    'Select File to Import
    
    Dim sFileName As String
    Dim sFileExt As String
    Dim vInput As Variant
    Dim vProcess() As String
    Dim lInputCount As Long
    Dim lFileIndex As Long
    Dim lFinalPathSepLoc As Long
    Dim s1Input As String
    Dim sServer As String
    Dim sFullPathFileName As String
    Dim lSuccess As Long
    Const bMultiSelect As Boolean = False
    Dim sngRatioToFit As Single
    
    'If you want to use the current path as the start of the search location
    '    for your images you do not need any of the followiing block of code:
    '=========================================================================
    'Set location that the directory search should start
    If InStr(1, Application.OperatingSystem, "Windows") > 0 Then
        'Using windows system, set the default path for windows
        If ThisWorkbook.Path = vbNullString Then
            'The file has not yet been saved use the user default picture dir
            ChDir Environ("USERPROFILE") & "\Pictures"
            ChDrive Environ("USERPROFILE") & "\Pictures"
        Else
            'Use the location of this file as the initial search location
            If Left(ThisWorkbook.Path, 2) = "" Then
                'This workbook.path is defined using UNC
                lSuccess = SetCurrentDirectoryA(ThisWorkbook.Path)
                If lSuccess = 0 Then MsgBox "Unable to connect to " & vbLf & vbLf & _
                    sServer: Exit Sub
            Else
                'This workbook location is defined by a mapped drive address (such as D:\)
                'Change ThisWorkbook.Path in next 2 statements to environ("USERPROFILE") & "\Pictures" if
                ' The initial image directory should be the user's picture directory
                ChDir Environ("USERPROFILE") & "\Pictures"
                ChDrive Environ("USERPROFILE") & "\Pictures"
'                or this workbook's path
'                ChDrive ThisWorkbook.Path
'                ChDir ThisWorkbook.Path
'                or comment out this entire section (between ==== lines) to use the
'                CurDir in effect when this code was run
            End If
        End If
        
    Else
        'put code her to set MAC Directory location where the file selection
        '    for picture files will start.
        'sorry i can help with this bit, as i have never worked with macs.
    End If
    '=========================================================================
    
    
    
    'This section will open a dialog box that allows you to select a single file
    'It will start on the current directory (which may have been changed by
    'above code from what it was when the code was started.)
    '=========================================================================
    vInput = True
    'Open the standard Open dialog box at the specified location
    vInput = Application.GetOpenFilename("All Files (*.*), *.*", _
        , "Select a picture file to insert into the selected cell", "Only Mac Button Face", bMultiSelect)
        'If Cancel is selected vInput is always False
        'With MS True when one or more files are selected vInput is an array
        'With MS False when one file is selected vInput is a string
        
    On Error Resume Next  'Will cause an error if nothing selected
    If vInput <> False Then
        sFilePathNameExt = vInput
        On Error GoTo 0
            s1Input = sFilePathNameExt
            lFinalPathSepLoc = InStrRev(s1Input, Application.PathSeparator)
            sFilePath = CStr(Left(s1Input, lFinalPathSepLoc))
            sFileNameExt = CStr(Mid(s1Input, lFinalPathSepLoc + 1))
            sFileName = Left(sFileNameExt, InStr(sFileNameExt, ".") - 1)
            sFileExt = Mid(sFileNameExt, InStr(sFileNameExt, ".") + 1)
            
            '(Do stuff here with each filename in loop)

        'Next
    Else
        'User cancelled image selection
        GoTo End_Sub
    End If
    On Error GoTo 0
    '=========================================================================
    
    ActiveSheet.Pictures.Insert(sFilePathNameExt).Select
    
    'Compare the picture aspect ratio to the cell aspect ratio
    'Shrink picture as necessary to fit cell
    If bKeepPixAspectRatio Then
        If Selection.Height / sngCellHeight > Selection.Width / sngCellWidth Then
            sngRatioToFit = sngCellHeight / Selection.Height
        Else
            sngRatioToFit = sngCellWidth / Selection.Width
        End If
        Selection.ShapeRange.LockAspectRatio = msoTrue
        Selection.ShapeRange.ScaleHeight sngRatioToFit, msoFalse, msoScaleFromTopLeft
    Else
        Selection.ShapeRange.LockAspectRatio = msoFalse
        Selection.Height = sngCellHeight
        Selection.Width = sngCellWidth
    End If
    
    Selection.OnAction = "TogglePict"   'Sets the TogglePict macro to run when the image is clicked
    Selection.Name = sCellAddr          'Sets the name of the picture to the cell address
                                            'that was selected when the sub was run
    
End_Sub:

End Sub


Sub TogglePict()
    'Assumes the original picture size is larger than the cell size
    
    Dim sName As String
    Dim sCellAddr As String
    
    Dim sngCellHeight As Single
    Dim sngCellWidth As Single
    Dim sngCellRatio As Single
    
    Dim sngPixHeight As Single
    Dim sngPixWidth As Single
    Dim sngPixRatio As Single
    
    Dim sngOrigPixHeight As Single
    Dim sngOrigPixWidth As Single
    Dim sngOrigPixRatio As Single
    
    Dim sngRatioToFit As Single
    
    sName = Application.Caller  'Determines the name of the image that started the code
    
    sngOrigPixHeight = ActiveSheet.Shapes(sName).Height
    sngOrigPixWidth = ActiveSheet.Shapes(sName).Width
    sngOrigPixRatio = sngOrigPixHeight / sngOrigPixWidth
    
    sngCellHeight = Range(sName).Height
    sngCellWidth = Range(sName).Width
    sngCellRatio = sngCellHeight / sngCellWidth
    
    If sngOrigPixHeight <= sngCellHeight And sngOrigPixWidth <= sngCellWidth Then
        'Picture is shrunk in the cell, so enlarge it and center it
        ActiveSheet.Shapes(sName).LockAspectRatio = msoFalse
        sngPixHeight = ActiveSheet.Shapes(sName).ScaleHeight(1, msoTrue)
        sngPixWidth = ActiveSheet.Shapes(sName).ScaleWidth(1, msoTrue)
        ActiveSheet.Shapes(sName).LockAspectRatio = msoTrue
        
        ActiveSheet.Shapes(sName).Left = (ActiveWindow.Width - ActiveSheet.Shapes(sName).Width) / 2
        ActiveSheet.Shapes(sName).Top = (ActiveWindow.Height - ActiveSheet.Shapes(sName).Height) / 2
        ActiveSheet.Shapes(sName).ZOrder msoBringToFront
    Else
        'Picture is out of the cell and needs to be put into it
        If bKeepPixAspectRatio Then
            
            If ActiveSheet.Shapes(sName).Height / sngCellHeight > ActiveSheet.Shapes(sName).Width / sngCellWidth Then
                sngRatioToFit = sngCellHeight / ActiveSheet.Shapes(sName).Height
            Else
                sngRatioToFit = sngCellWidth / ActiveSheet.Shapes(sName).Width
            End If
            ActiveSheet.Shapes(sName).LockAspectRatio = msoTrue
            ActiveSheet.Shapes(sName).ScaleHeight sngRatioToFit, msoFalse, msoScaleFromTopLeft
        Else
            ActiveSheet.Shapes(sName).ShapeRange.LockAspectRatio = msoFalse
            ActiveSheet.Shapes(sName).Height = sngCellHeight
            ActiveSheet.Shapes(sName).Width = sngCellWidth
        End If
        ActiveSheet.Shapes(sName).Left = Range(sName).Left
        ActiveSheet.Shapes(sName).Top = Range(sName).Top
        ActiveSheet.Shapes(sName).ZOrder msoSendToBack
        
    End If
    
    Application.ScreenUpdating = True
    
    
End Sub
 
Last edited:
Upvote 0

Excel Facts

How to total the visible cells?
From the first blank cell below a filtered data set, press Alt+=. Instead of SUM, you will get SUBTOTAL(9,)
The code works for my system (Windows 7). Does it work on your windows, but not on the Mac or not at all?

Is the code for inserting the pictures working?
Right-clicking in a cell and will trigger the InsertPictureIntoSelectedCell code which asks the user to select a picture.

Is TogglePict triggering when a picture inserted by InsertPictureIntoSelectedCell is clicked?
Check by adding a Stop statement after the
Sub TogglePict()
line to see if the code is triggering when a photo is clicked. If so, single-step through the code to see if all lines execute or if an error is raised.

If not, ensure that Application.EnableEvents is True on your system
by entering ?Application.EnableEvents in your immediate window
If it is false then put
Application.EnableEvents =True
and press return

I made a slight change in the way the program checks the status of the image in the TogglePict code, it will now correctly handle pictures that are smaller than the cell. Replace the original TogglePict with the following:

Code:
Sub TogglePict()
    'Assumes the original picture size is larger than the cell size
    
    Dim sName As String
    Dim sCellAddr As String
    
    Dim sngCellHeight As Single
    Dim sngCellWidth As Single
    Dim sngCellRatio As Single
    
    Dim sngPixHeight As Single
    Dim sngPixWidth As Single
    Dim sngPixRatio As Single
    
    Dim sngOrigPixHeight As Single
    Dim sngOrigPixWidth As Single
    Dim sngOrigPixRatio As Single
    
    Dim sngRatioToFit As Single
    
    sName = Application.Caller  'Determines the name of the image that started the code
    
    sngOrigPixHeight = ActiveSheet.Shapes(sName).Height
    sngOrigPixWidth = ActiveSheet.Shapes(sName).Width
    sngOrigPixRatio = sngOrigPixHeight / sngOrigPixWidth
    
    sngCellHeight = Range(sName).Height
    sngCellWidth = Range(sName).Width
    sngCellRatio = sngCellHeight / sngCellWidth
    
    If sName = ActiveSheet.Shapes(sName).TopLeftCell.Address(False, False) Then
        'Picture is located in its storage cell, so restore its size and center it
    'If sngOrigPixHeight <= sngCellHeight And sngOrigPixWidth <= sngCellWidth Then
        'Picture is shrunk in the cell, so enlarge it and center it
        ActiveSheet.Shapes(sName).LockAspectRatio = msoFalse
        sngPixHeight = ActiveSheet.Shapes(sName).ScaleHeight(1, msoTrue)
        sngPixWidth = ActiveSheet.Shapes(sName).ScaleWidth(1, msoTrue)
        ActiveSheet.Shapes(sName).LockAspectRatio = msoTrue
        
        ActiveSheet.Shapes(sName).Left = (ActiveWindow.Width - ActiveSheet.Shapes(sName).Width) / 2
        ActiveSheet.Shapes(sName).Top = (ActiveWindow.Height - ActiveSheet.Shapes(sName).Height) / 2
        ActiveSheet.Shapes(sName).ZOrder msoBringToFront
        
    Else
        'Picture is out of the cell and needs to be put into it
        If bKeepPixAspectRatio Then
            
            If ActiveSheet.Shapes(sName).Height / sngCellHeight > ActiveSheet.Shapes(sName).Width / sngCellWidth Then
                sngRatioToFit = sngCellHeight / ActiveSheet.Shapes(sName).Height
            Else
                sngRatioToFit = sngCellWidth / ActiveSheet.Shapes(sName).Width
            End If
            ActiveSheet.Shapes(sName).LockAspectRatio = msoTrue
            ActiveSheet.Shapes(sName).ScaleHeight sngRatioToFit, msoFalse, msoScaleFromTopLeft
        Else
            ActiveSheet.Shapes(sName).ShapeRange.LockAspectRatio = msoFalse
            ActiveSheet.Shapes(sName).Height = sngCellHeight
            ActiveSheet.Shapes(sName).Width = sngCellWidth
        End If
        ActiveSheet.Shapes(sName).Left = Range(sName).Left
        ActiveSheet.Shapes(sName).Top = Range(sName).Top
        ActiveSheet.Shapes(sName).ZOrder msoSendToBack
        
    End If
    
    Application.ScreenUpdating = True
    
    
End Sub
 
Upvote 0
So far so good. But when I click on the picture again to size it back down I get a Run-time error '438' . Object doesn't support this property or method. It calls out

Else
ActiveSheet.Shapes(sName).ShapeRange.LockAspectRatio = msoFalse

on the debug.

Additionally if I run the debug by itself I also get the following error: Run-tim error '13': Type mismatch on the sName = Application.Caller
 
Last edited:
Upvote 0
Does Post #13 refer to the windows version?

See what your VBA help says about LockAspectRatio and Application.Caller they may have changed in your later version.

If you click on an image Application.Caller should return a string

Put this code before the 'sName = Application.Caller' line and see what is displayed in the message box:

Code:
Select Case TypeName(Application.Caller)
    Case "Range"
        v = Application.Caller.Address
    Case "String"
        v = Application.Caller
    Case "Error"
        v = "Error"
    Case Else
        v = "unknown"
End Select
MsgBox  TypeName(Application.Caller) &  " caller = " & v

Did you change 'bKeepPixAspectRatio' to false?
You should not get to 'ActiveSheet.Shapes(sName).ShapeRange.LockAspectRatio = msoFalse' otherwise. Ensure it is set to true at the top of the module that contains both InsertPictureIntoSelectedCell and TogglePict
 
Upvote 0
And I am doing all of the testing in Windows at this time. Win 7 laptop with Excel 2013. Working with the mac is just a convenience at this time for my QC purposes. I'm more worried about tech's using this in the field and the customer using it when they get the final survey.

When I put that code in the response came back with String Caller and the cell I inserted the picture in. I received the same error message as earlier when I tried to bring it back down.
 
Last edited:
Upvote 0
FYI. I disabled the line of code on the debug: ActiveSheet.Shapes(sName).ShapeRange.LockAspectRatio = msoFalse and it works now.

Suggestions?
 
Upvote 0
Ok. Before suggestions, disabling that obviously messed something up. After testing I discovered the following:


  • You can only pull pictures from the My Pictures you called out in the code. If I pull them from anywhere else the picture will place itself off to the right of the established cells. If you click it, it will move over to the cell you intended for it to go, however, if you try to enlarge it, it does nothing. When you pull from My Pictures it goes right straight to the cell.
  • The pictures are blowing up larger than the screen so you are only able to see the upper left hand corner of the pic.
  • Whenever you click to go to photos it doesn't remember the last place you went. (I can work around that but I just thought I would let you know).
  • The dialogue you included in the code (when the right click happens) is not popping up.

Question: Would it be better to bury a button in each cell instead of a right click?
 
Upvote 0
Modified code to get rid of the bKeepPixAspectRatio variable and code that used it.
Try this reworked code.

All of the below should go into a standard Module and the Private Sub Worksheet_BeforeRightClick code into the codepage of each worksheet where data will be stored.

Code:
Option Explicit
'https://www.mrexcel.com/forum/excel-questions/1039443-inserting-resizing-pics.html

'=========================================================================
'If you will never use a UNC path, this block of text is not required
'This allows the program to accept a Window UNC path in the ChDir function
'    Window UNC path is similar to: \\Server\Directory\SubDirectory
'    Instead of only understanding a reference to a mapped letter drive:
'        C:\Directory\SubDirectory
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  Win64 Then ' Win64    other option would be if VBA7
    Private Declare PtrSafe Function SetCurrentDirectoryA Lib "kernel32" _
        (ByVal lpPathName As String) As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL]  ' Downlevel when using previous version of VBA7
    Private Declare Function SetCurrentDirectoryA Lib "kernel32" _
        (ByVal lpPathName As String) As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
'=========================================================================

'Add the Private Sub below to all worksheets where you want to insert pictures
'When a cell is right-clicked the code to insert a photo will be triggered
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
    InsertPictureIntoSelectedCell
End Sub
'End Add the Private Sub

Sub InsertPictureIntoSelectedCell()
    'Assumes original picture size is larger than the cell size
    'Assumes original aspect ration should be retained
    
    Dim sCellAddr As String
    Dim sngCellHeight As Single
    Dim sngCellWidth As Single
    Dim sngPixHeight As Single
    Dim sngPixWidth As Single
    Dim sFilePathNameExt As String
    Dim sFilePath As String
    Dim sFileNameExt As String
    
    'Only a single cell can be double-clicked on at a time
    If Selection.Cells.Count > 1 Then
        MsgBox "Select the single cell where the picture will be inserted.", , "Select 1 Cell"
        GoTo End_Sub
    End If
    
    'Get dimensions & and address of the cell that was clicked on
    sngCellHeight = Selection.Height
    sngCellWidth = Selection.Width
    sCellAddr = Selection.Address(False, False)
    
    'Select File to Import
    
    Dim sFileName As String
    Dim sFileExt As String
    Dim vInput As Variant
    Dim vProcess() As String
    Dim lInputCount As Long
    Dim lFileIndex As Long
    Dim lFinalPathSepLoc As Long
    Dim s1Input As String
    Dim sServer As String
    Dim sFullPathFileName As String
    Dim lSuccess As Long
    Const bMultiSelect As Boolean = False
    Dim sngRatioToFit As Single
    
    'If you want to use the current path as the start of the search location
    '    for your images you do not need any of the followiing block of code:
    '=========================================================================
    'Set location that the directory search should start
    If InStr(1, Application.OperatingSystem, "Windows") > 0 Then
        'Using windows system, set the default path for windows
        If ThisWorkbook.Path = vbNullString Then
            'The file has not yet been saved use the user default picture dir
            ChDir Environ("USERPROFILE") & "\Pictures"
            ChDrive Environ("USERPROFILE") & "\Pictures"
        Else
            'Use the location of this file as the initial search location
            If Left(ThisWorkbook.Path, 2) = "\" Then
                'This workbook.path is defined using UNC
                lSuccess = SetCurrentDirectoryA(ThisWorkbook.Path)
                If lSuccess = 0 Then MsgBox "Unable to connect to " & vbLf & vbLf & _
                    sServer: Exit Sub
            Else
                'This workbook location is defined by a mapped drive address (such as D:\)
                'Change ThisWorkbook.Path in next 2 statements to environ("USERPROFILE") & "\Pictures" if
                ' The initial image directory should be the user's picture directory
                ChDir Environ("USERPROFILE") & "\Pictures"
                ChDrive Environ("USERPROFILE") & "\Pictures"
'                or this workbook's path
'                ChDrive ThisWorkbook.Path
'                ChDir ThisWorkbook.Path
'                or comment out this entire section (between ==== lines) to use the
'                CurDir in effect when this code was run
            End If
        End If
        
    Else
        'put code her to set MAC Directory location where the file selection
        '    for picture files will start.
        'sorry i can help with this bit, as i have never worked with macs.
    End If
    '=========================================================================
    
    
    
    'This section will open a dialog box that allows you to select a single file
    'It will start on the current directory (which may have been changed by
    'above code from what it was when the code was started.)
    '=========================================================================
    vInput = True
    'Open the standard Open dialog box at the specified location
    vInput = Application.GetOpenFilename("All Files (*.*), *.*", _
        , "Select a picture file to insert into the selected cell", "Only Mac Button Face", bMultiSelect)
        'If Cancel is selected vInput is always False
        'With MS True when one or more files are selected vInput is an array
        'With MS False when one file is selected vInput is a string
        
    On Error Resume Next  'Will cause an error if nothing selected
    If vInput <> False Then
        sFilePathNameExt = vInput
        On Error GoTo 0
            s1Input = sFilePathNameExt
            lFinalPathSepLoc = InStrRev(s1Input, Application.PathSeparator)
            sFilePath = CStr(Left(s1Input, lFinalPathSepLoc))
            sFileNameExt = CStr(Mid(s1Input, lFinalPathSepLoc + 1))
            sFileName = Left(sFileNameExt, InStr(sFileNameExt, ".") - 1)
            sFileExt = Mid(sFileNameExt, InStr(sFileNameExt, ".") + 1)
            
            '(Do stuff here with each filename in loop)

        'Next
    Else
        'User cancelled image selection
        GoTo End_Sub
    End If
    On Error GoTo 0
    '=========================================================================
    
    ActiveSheet.Pictures.Insert(sFilePathNameExt).Select
    
    'Ensure inserted picture is at full size (Insert shrinks large pictures)
    Selection.Name = sCellAddr          'Sets the name of the picture to the cell address
                                            'that was selected when the sub was run
    Selection.ShapeRange.LockAspectRatio = msoFalse
    ActiveSheet.Shapes(sCellAddr).ScaleHeight 1, msoTrue
    ActiveSheet.Shapes(sCellAddr).ScaleWidth 1, msoTrue
    Selection.ShapeRange.LockAspectRatio = msoTrue
    
    'Compare the picture aspect ratio to the right-clicked cell suze & aspect ratio
    'Shrink picture as necessary to fit cell
    If Selection.Height / sngCellHeight > Selection.Width / sngCellWidth Then
        sngRatioToFit = sngCellHeight / Selection.Height
    Else
        sngRatioToFit = sngCellWidth / Selection.Width
    End If
    Selection.ShapeRange.LockAspectRatio = msoTrue
    Selection.ShapeRange.ScaleHeight sngRatioToFit, msoFalse, msoScaleFromTopLeft
    
    Selection.OnAction = "TogglePict"   'Sets the TogglePict macro to run when the image is clicked
    Selection.Name = sCellAddr          'Sets the name of the picture to the cell address
                                            'that was selected when the sub was run
    
End_Sub:

End Sub

Sub TogglePict()
    
    Dim sName As String
    Dim sCellAddr As String
    
    Dim sngCellHeight As Single
    Dim sngCellWidth As Single
    Dim sngCellRatio As Single
    
    Dim sngPixHeight As Single
    Dim sngPixWidth As Single
    Dim sngPixRatio As Single
    
    Dim sngOrigPixHeight As Single
    Dim sngOrigPixWidth As Single
    Dim sngOrigPixRatio As Single
    
    Dim sngRatioToFit As Single
    
    Dim sngViewHeightMax As Single
    Dim sngViewWidthMax As Single
    
    'Reduce the size of the max view so no part of the enlarged picture is below the
    '    Sheet Name Tabs or Statusbar
    sngViewHeightMax = 0.9 * ActiveWindow.UsableHeight
    sngViewWidthMax = 0.9 * ActiveWindow.UsableWidth
    
    sName = Application.Caller  'Determines the name of the image that started the code
    
    sngOrigPixHeight = ActiveSheet.Shapes(sName).Height
    sngOrigPixWidth = ActiveSheet.Shapes(sName).Width
    sngOrigPixRatio = sngOrigPixHeight / sngOrigPixWidth
    
    sngCellHeight = Range(sName).Height
    sngCellWidth = Range(sName).Width
    sngCellRatio = sngCellHeight / sngCellWidth
    
    'Is the UL corner of picture in its storage cell (or displayed at its full size)
    If sName = ActiveSheet.Shapes(sName).TopLeftCell.Address(False, False) Then
        'Picture is located in its storage cell, so restore its size and center it
        'Allow aspect ratio to revert back to original value in case someone changed it
        ActiveSheet.Shapes(sName).LockAspectRatio = msoFalse
        'Set height and width back to original size
        sngPixHeight = ActiveSheet.Shapes(sName).ScaleHeight(1, msoTrue)
        sngPixWidth = ActiveSheet.Shapes(sName).ScaleWidth(1, msoTrue)
        'Lock in original aspect ratio
        ActiveSheet.Shapes(sName).LockAspectRatio = msoTrue
        
        'If picture is larger than the screen, shrink so it is smaller.  Keep aspect ratio
        If ActiveSheet.Shapes(sName).Height > sngViewHeightMax Or ActiveSheet.Shapes(sName).Width > sngViewWidthMax Then
            If ActiveSheet.Shapes(sName).Height / sngViewHeightMax > ActiveSheet.Shapes(sName).Width / sngViewWidthMax Then
                sngRatioToFit = sngViewHeightMax / ActiveSheet.Shapes(sName).Height
            Else
                sngRatioToFit = sngViewWidthMax / ActiveSheet.Shapes(sName).Width
            End If
            ActiveSheet.Shapes(sName).ScaleHeight sngRatioToFit, msoTrue, msoScaleFromTopLeft
        End If
        
        'Center Picture in Excel Window
        ActiveSheet.Shapes(sName).Left = 0.05 * sngViewWidthMax + ((sngViewWidthMax - ActiveSheet.Shapes(sName).Width) / 2)
        ActiveSheet.Shapes(sName).Top = 0.05 * sngViewHeightMax + ((sngViewHeightMax - ActiveSheet.Shapes(sName).Height) / 2)
        ActiveSheet.Shapes(sName).ZOrder msoBringToFront
        
    Else
        'Picture is out of the cell and needs to be put into it
        If ActiveSheet.Shapes(sName).Height / sngCellHeight > ActiveSheet.Shapes(sName).Width / sngCellWidth Then
            sngRatioToFit = sngCellHeight / ActiveSheet.Shapes(sName).Height
        Else
            sngRatioToFit = sngCellWidth / ActiveSheet.Shapes(sName).Width
        End If
        ActiveSheet.Shapes(sName).LockAspectRatio = msoTrue
        'Resize picture to fit in storage cell
        ActiveSheet.Shapes(sName).ScaleHeight sngRatioToFit, msoFalse, msoScaleFromTopLeft
        'Move UL corner of picture to UL corner of storage cell
        ActiveSheet.Shapes(sName).Left = Range(sName).Left
        ActiveSheet.Shapes(sName).Top = Range(sName).Top
        ActiveSheet.Shapes(sName).ZOrder msoSendToBack
        
    End If
    
    Application.ScreenUpdating = True
    
End Sub

Sub DisplayFullScreen_True()
    'Hides toolbars, formula bar and various other items
    Application.DisplayFullScreen = True
End Sub

Sub DisplayFullScreen_False()
    'Unhides hidden toolbars, formula bar and various other items
    Application.DisplayFullScreen = False
End Sub
 
Upvote 0

Forum statistics

Threads
1,223,911
Messages
6,175,329
Members
452,635
Latest member
laura12345

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