Moving Comment Background Pictures to Cells

Attention: A "funny" thing with .LockAspectRatio = msoTrue is the following:

The standard shape of a comment is a rectangle. It shows four circles in each corners and four circels in each middle of the sides.

If .LockAspectRatio = msoTrue is used the AspectRatio is only locked, if the comment shape is drawn at the circles in the corners.

But the AspectRatio is easily destroyed, if the comment shape is drawn left or right, up or down at the circles in the middle of the sides.

So anybody else who is using the workbook together with others can destroy the AspectRatio of the background pictures easily. If the worksheets in the workbook have a large amount of comments with background pictures it is not affordable to rescue distorted AspectRatios for the pictures manually.

(see Figure 1 below)

To make sense to move comment background pictures to cells it is necessary to preserve the scale of the inserted user picture:

Sub insert_userpicture_in_comments()

Dim rngZelle As Range

Dim strFilename As Variant
Dim strFilter As String
Dim ScaleValue As Single
Dim ScaleValue2 As Single

Dim objPic As IPictureDisp
Dim Source As String

Dim i As Integer

If ActiveSheet.Comments.Count = 0 Then
MsgBox "No comments in entire sheet"
Exit Sub
End If

strFilter = "JPG Files (*.jpg), *.jpg" _
& ", GIF Files (*.gif), *.gif" _
& ", Bitmaps (*.bmp), *.bmp" _
& ", WMF Files (*.wmf), *.wmf"

strFilename = Application.GetOpenFilename(strFilter)

If strFilename = False Then GoTo LabelA

Source = (CStr(strFilename))

Set objPic = LoadPicture(Source)

With objPic
ScaleValue = .Width / .Height
End With

If MsgBox(ScaleValue, vbOKCancel) = vbCancel Then GoTo LabelA

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

For Each rngZelle In Selection.Cells
With rngZelle
If Not .Comment Is Nothing Then

With .Comment.Shape

.Shadow.Visible = msoFalse

.LockAspectRatio = msoFalse
.Width = 150
' .Width = ScaleValue * .Height
.Height = .Width / ScaleValue
.Fill.UserPicture strFilename
.LockAspectRatio = msoTrue

ScaleValue2 = .Width / .Height

End With
End If
End With
Next rngZelle

LabelA:

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

Back to the comment standard leads: .Shape.Fill.Solid

With cmt
bVisible = .Visible
.Visible = True
Set rCell = .Parent.Offset(0, 1)
.Shape.CopyPicture _
Appearance:=xlScreen, Format:=xlPicture
rCell.PasteSpecial
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.Width = rCell.Width
Selection.Height = rCell.Height
.Visible = bVisible

.Shape.Fill.Solid

End With

Perfect macro, it was helpful for me. Thanks a lot. I deleted the row SHAPE.FILL to keep picture also in the comment.