I am using an existing VBA code to insert an image into a comment box in Excel. I would like to lock the aspect ratio of the comment box, and also select the "Do not move or size with cell"
EDIT - Posted the code with @Ryan B. 's help - Works perfectly!
Sub add_content_image()
'NOTE: THE RESIZER ONLY WORKS FOR JPG IMAGES
Dim myFile As FileDialog, ImgFile, myImg As Variant
Dim ZoomF As Variant 'string
On Error Resume Next
Set myFile = Application.FileDialog(msoFileDialogOpen)
With myFile
.Title = "Choose File"
.AllowMultiSelect = False
.Filters.Add Description:="Images", Extensions:="*.jpg,*.Jpg,*.gif,*.png,*.tif,*.bmp", Position:=1
If .Show <> -1 Then
MsgBox "No image selected", vbCritical
Exit Sub
End If
End With
ImgFile = myFile.SelectedItems(1)
If ImgFile = False Then Exit Sub
Application.ScreenUpdating = False
ZoomF = InputBox(Prompt:="Your selected file path:" & _
vbNewLine & ImgFile & _
vbNewLine & "" & _
vbNewLine & "Input zoom % factor to apply to picture?" & _
vbNewLine & "(Original picture size equals 100) ." & _
vbNewLine & "Input a number greater than zero!", Title:="Picture Scaling Percentage Factor", Default:=100)
If Not IsNumeric(ZoomF) Or ZoomF = 0 Or ZoomF = "" Then
MsgBox "You must enter a valid numeric value. Entered value must be a number greater than zero." & _
vbNewLine & "Macro will terminate.", vbCritical
Exit Sub
End If
With ActiveCell
.ClearComments
.AddComment
.Interior.ColorIndex = 19
.Value = "Hover for Image"
End With
Set myImg = LoadPicture(ImgFile)
With ActiveCell.Comment
.Shape.Fill.UserPicture ImgFile
.Shape.Width = myImg.Width * ZoomF / 2645.9
.Shape.Height = myImg.Height * ZoomF / 2645.9
.Shape.LockAspectRatio = msoTrue
.Shape.Placement = 3 'do not move or size with cells
End With
Application.ScreenUpdating = True
Set myFile = Nothing: Set myImg = Nothing
End Sub
Given your block of code:
With ActiveCell.Comment
.Shape.Fill.UserPicture ImgFile
.Shape.Width = myImg.Width * ZoomF / 2645.9
.Shape.Height = myImg.Height * ZoomF / 2645.9
.ShapeRange.LockAspectRatio = msoTrue 'this does not seem to work
.Shape.Placement = 2 'move but do not size with cells
End With
I believe you want to change this line:
.ShapeRange.LockAspectRatio = msoTrue
to this:
.Shape.LockAspectRatio = msoTrue
There isn't a 'ShapeRange' property on a Comment object. So your code is generating an error there. But, because you've declared "OnErrorResumeNext" the execution ignores the error and starts on the next line.
So, you don't see any problems, but your attempt to change the LockAspectRatio property doesn't actually work, and then the bit that comes after to change the Position property never gets executed. Fixing the one line of code should solve both problems.