This is probably super easy for some, but certainly not for me. I have an inventory worksheet inside inventory.xlsm workbook with lots of product pictures. I use a macro called FitPic()
to fit them into the cells. I require that when the macro is run it would do its usual stuff, but also assign a macro called ClickResizeImage()
to the picture shape.
Public Sub FitPic()
On Error GoTo NOT_SHAPE
Dim Pic As Object
Dim PicWtoHRatio As Single
Dim CellWtoHRatio As Single
If TypeName(Selection) = "DrawingObjects" Then
For Each Pic In Selection.ShapeRange
FitIndividualPic Pic
Next Pic
Else
FitIndividualPic Selection
End If
Exit Sub
NOT_SHAPE:
MsgBox "Select a picture before running this macro." & " Num" & Count
End Sub
Public Sub FitIndividualPic(Pic As Object)
Dim Gap As Single
Gap = 0.75
With Pic
Pic.Placement = xlMoveAndSize
PicWtoHRatio = (.Width / .Height)
End With
With Pic.TopLeftCell
CellWtoHRatio = .Width / .RowHeight
End With
Select Case PicWtoHRatio / CellWtoHRatio
Case Is > 1
With Pic
.Width = .TopLeftCell.Width - Gap
.Height = .Width / PicWtoHRatio - Gap
End With
Case Else
With Pic
.Height = .TopLeftCell.RowHeight - Gap
.Width = .Height * PicWtoHRatio - Gap
End With
End Select
With Pic
.Top = .TopLeftCell.Top + Gap
.Left = .TopLeftCell.Left + Gap
End With
End Sub
And this here is the ClickResizeImage()
which of course works fine as a standalone.
Sub ClickResizeImage()
Dim shp As Shape
Dim big As Single, small As Single
Dim shpDouH As Double, shpDouOriH As Double
big = 8
small = 1
On Error Resume Next
Set shp = ActiveSheet.Shapes(Application.Caller)
With shp
shpDouH = .Height
.ScaleHeight 1, msoTrue, msoScaleFromTopLeft
shpDouOriH = .Height
If Round(shpDouH / shpDouOriH, 2) = big Then
.ScaleHeight small, msoTrue, msoScaleFromTopLeft
.ScaleWidth small, msoTrue, msoScaleFromTopLeft
.ZOrder msoSendToBack
Else
.ScaleHeight big, msoTrue, msoScaleFromTopLeft
.ScaleWidth big, msoTrue, msoScaleFromTopLeft
.ZOrder msoBringToFront
End If
End With
End Sub
Dim Pic As Shape
(change from Object). Then add the following code immediately after the line FitIndividualPic Pic
in Sub FitPic()
: Pic.OnAction = "ClickResizeImage"
.
To be clear, this should be your new FitPic()
:
Public Sub FitPic()
On Error GoTo NOT_SHAPE
Dim Pic As Shape
Dim PicWtoHRatio As Single
Dim CellWtoHRatio As Single
If TypeName(Selection) = "DrawingObjects" Then
For Each Pic In Selection.ShapeRange
FitIndividualPic Pic
Pic.OnAction = "ClickResizeImage"
Next Pic
Else
FitIndividualPic Selection
Selection.OnAction = "ClickResizeImage" 'also assigns the macro to the Selection
End If
Exit Sub
NOT_SHAPE:
MsgBox "Select a picture before running this macro." & " Num" & Count
End Sub
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.