Help with picture ratio in Macro

[alekun86]

Dear all,

I need your help with pic ratio inside the following formula.
The pic is correctly pasted in memo, the height changes to 200, but the original ratio is not maintained. Can you help me?


Sub showPic()

Dim folderPath As String

folderPath = ThisWorkbook.path & Application.PathSeparator

For Each cell In Selection

fileExt = cell.Value & ".jpg"

If Dir(folderPath & fileExt) = fileExt Then

MyPicture = folderPath & cell.Value & ".jpg"

With cell.AddComment

.Shape.Fill.UserPicture MyPicture
.Shape.Fill.UserPicture MyPicture
.Shape.LockAspectRatio = msoTrue
.Shape.Height = 200


End With

End If

Next cell

End Sub

 

[rlv01]

It is because the shape you are working with is the Excel comment, not the image.

            With Cell.AddComment
                .Shape.Fill.UserPicture MyPicture
                .Shape.Fill.UserPicture MyPicture
                .Shape.LockAspectRatio = msoTrue
                .Shape.Height = 200
            End With

When you lock the aspect ratio, you are doing it to the comment, not the image. So you need to set the comment to the correct aspect ratio for the image you are importing first.

Sub showPic()
    Dim folderPath As String, fileExt As String, MyPicture As String
    Dim srcCell As Range
    Dim P As Picture
    Dim PARatio As Double

    folderPath = ThisWorkbook.Path & Application.PathSeparator

    For Each srcCell In Selection
        fileExt = srcCell.Value & ".jpg"

        If Dir(folderPath & fileExt) = fileExt Then
            Set P = ActiveSheet.Pictures.Insert(folderPath)
            PARatio = P.Width / P.Height
            P.Delete
            Set P = Nothing
           
            If Not srcCell.Comment Is Nothing Then
                srcCell.Comment.Delete
            End If

            MyPicture = folderPath & srcCell.Value & ".jpg"
           
            With srcCell.AddComment
                .Shape.Height = 200
                .Shape.Width = PARatio * .Shape.Height
                .Shape.LockAspectRatio = msoTrue
                .Shape.Fill.UserPicture MyPicture
            End With
        End If
    Next srcCell
End Sub

(Tip: when posting code, please try to use 'code tags' to format the code as I have done above

How to Post Your VBA Code

as it makes the code easier to read.)