Option Explicit
'https://www.mrexcel.com/forum/excel-questions/1039443-inserting-resizing-pics.html
'https://www.mrexcel.com/forum/excel-questions/1043513-vba-code-needed-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: [URL="file://\\Server\Directory\SubDirectory"]\\Server\Directory\SubDirectory[/URL]
' 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 ScanWorksheetUpdatePictures()
'This code assumes:
' 1) Files in the target directory all have unique names (none with same
' name and different extension.
' 2) The names in the worksheet correspond to image filenames in the target
' directory
Dim sPath As String
'=============================== UPDATE THIS PATH ====================================
sPath = Environ("userprofile") & "\Documents\-- Excel Processing\MrE\Image Placement"
Dim shp As Shape
Dim rngCell As Range
Dim sFilePathNameExt As String
Dim sFileNameExt As String
Dim sFileName As String
Dim sCellAddr As String
Dim sngCellHeight As Single
Dim sngCellWidth As Single
Dim sngRatioToFit As Single
If Right(sPath, 1) <> "" Then sPath = sPath & ""
With ActiveSheet
'Delete all images from activeworksheet
For Each shp In .Shapes: shp.Delete: Next
For Each rngCell In .UsedRange.SpecialCells(xlCellTypeConstants, 2)
'Check each cell containing text
sFileName = rngCell.Text
sFileNameExt = Dir(sPath & sFileName & ".*")
If sFileNameExt <> vbNullString Then
sFilePathNameExt = sPath & sFileNameExt
rngCell.Offset(0, 1).Select
'Get dimensions & and address of the cell to the right of rngCell
sngCellHeight = Selection.Height
sngCellWidth = Selection.Width
sCellAddr = Selection.Address(False, False)
ActiveSheet.Pictures.Insert(sFilePathNameExt).Select
'Ensure inserted picture is at full size (Insert shrinks large pictures)
Selection.Name = sFileName & "." & sCellAddr 'Adds the cell address to the filename
'that was selected when the sub was run
Selection.ShapeRange.LockAspectRatio = msoFalse
ActiveSheet.Shapes(Selection.Name).ScaleHeight 1, msoTrue
ActiveSheet.Shapes(Selection.Name).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
'that was selected when the sub was run
End If
Next
End With
End Sub
Sub InsertPictureIntoSelectedCell()
'Assumes original picture size is larger than the cell size
'Assumes original aspect ratio 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
sCellAddr = Mid(sName, InStr(sName, ".") + 1)
sngOrigPixHeight = ActiveSheet.Shapes(sName).Height
sngOrigPixWidth = ActiveSheet.Shapes(sName).Width
sngOrigPixRatio = sngOrigPixHeight / sngOrigPixWidth
sngCellHeight = Range(sCellAddr).Height
sngCellWidth = Range(sCellAddr).Width
sngCellRatio = sngCellHeight / sngCellWidth
'Is the UL corner of picture in its storage cell (or displayed at its full size)
If sCellAddr = 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 = ActiveWindow.VisibleRange.Left + _
(0.05 * sngViewWidthMax + ((sngViewWidthMax - ActiveSheet.Shapes(sName).Width) / 2))
ActiveSheet.Shapes(sName).Top = ActiveWindow.VisibleRange.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(sCellAddr).Left
ActiveSheet.Shapes(sName).Top = Range(sCellAddr).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
