Search code examples
excelvbaaspect-ratio

VBA Excel Comment Box - Enabling Lock Aspect Ratio


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

Solution

  • 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.