Option Explicit
Private Declare Function SetCurrentDirectoryA Lib "kernel32" _
(ByVal lpPathName As String) As Long
Const bKeepPixAspectRatio As Boolean = 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
'https://www.mrexcel.com/forum/excel-questions/1039443-inserting-resizing-pics.html
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
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
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 sIniPath As String
Dim sFullPathFileName As String
Dim lSuccess As Long
Const bMultiSelect As Boolean = False
Dim sngRatioToFit As Single
sIniPath = CurDir
'Set location that the directory search should start
If InStr(1, Application.OperatingSystem, "Windows") > 0 Then
If ThisWorkbook.Path = vbNullString Then
ChDir Environ("USERPROFILE") & "\Pictures\"
ChDrive Environ("USERPROFILE") & "\Pictures\"
Else
If Left(ThisWorkbook.Path, 2) = "\\" Then
lSuccess = SetCurrentDirectoryA(ThisWorkbook.Path)
If lSuccess = 0 Then MsgBox "Unable to connect to " & vbLf & vbLf & _
sServer: Exit Sub
Else
'Change ThisWorkbook.Path in next 2 statements to environ("USERPROFILE") & "\Pictures\" if
' The initial image directory should be the user's picture directory
'ChDrive ThisWorkbook.Path
'ChDir ThisWorkbook.Path
ChDir Environ("USERPROFILE") & "\Pictures\"
ChDrive Environ("USERPROFILE") & "\Pictures\"
End If
End If
Else 'put code her to set MAC Directory location sorry i can help with this bit, as i have never worked with macs.
End If
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
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"
Selection.Name = sCellAddr
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
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
