GDIplusCODE

Sub pastePic2Comment()
  Dim myComment As Comment
  Dim myWidth As Double, myHeight As Double
  Dim picPath As String
  Dim myPic As StdPicture
  Dim myRatio As Double
  Dim myChartObj As ChartObject
  Const longSideLength As Double = 300
 
  Application.ScreenUpdating = False
  picPath = Application.GetOpenFilename("画像ファイル , *.*")
  If picPath = "False" Then Exit Sub
  Set myPic = LoadPicture(picPath)
  myRatio = myPic.Width / myPic.Height
  Set myPic = Nothing
  If myRatio >= 1 Then
    myWidth = longSideLength: myHeight = longSideLength / myRatio
  Else
    myWidth = longSideLength * myRatio: myHeight = longSideLength
  End If
  'Sheet(2)のところはアクティブでないシートを指定して下さい。
  Set myChartObj = Sheets(2).ChartObjects.Add(0, 0, myWidth, myHeight)
  myChartObj.Chart.ChartArea.Fill.UserPicture PictureFile:=picPath
  myChartObj.Chart.Export "c:\temp.jpg"
  myChartObj.Delete
  ActiveCell.ClearComments
  Set myComment = ActiveCell.AddComment
  With myComment.Shape
    .Fill.Visible = msoTrue
    .Fill.UserPicture "C:\temp.jpg"
    .Width = myWidth
    .Height = myHeight
  End With
  Application.ScreenUpdating = True
End Sub

レジストリはRegEditによるか、下記URLのコードを利用させていただき、標準の75(0x4B)→一般的な設定の85に変更します。
レジストリのデータの在処は下記コードをご参照下さい。
'http://www31.ocn.ne.jp/~heropa/vb13.htm
Sub setRegistry()
    Debug.Print RegSetValue(HKEY_LOCAL_MACHINE, _
                            "SOFTWARE\Microsoft\Shared Tools\Graphics Filters\Export\JPEG\Options", _
                            "Quality", _
                            REG_DWORD, _
                            85)
End Sub

おまけ　：　JPEGファイルをリサイズしてJPEG保存するプロシージャ
（長辺のpixel数を渡す　－　ぴったりサイズにはならないのが難）

Private Sub resizeJpegFile(srcPicPath As String, destPicPath As String, longSideLength As Long)
  Dim myWidth As Double, myHeight As Double
  Dim myPic As StdPicture
  Dim myRatio As Double
  Dim myChartObj As ChartObject
  
  longSideLength = longSideLength * 72 / 96
  Application.ScreenUpdating = False
  Set myPic = LoadPicture(srcPicPath)
  myRatio = myPic.Width / myPic.Height
  Set myPic = Nothing
  If myRatio >= 1 Then
    myWidth = longSideLength: myHeight = longSideLength / myRatio
  Else
    myWidth = longSideLength * myRatio: myHeight = longSideLength
  End If
  Set myChartObj = ActiveSheet.ChartObjects.Add(0, 0, myWidth, myHeight)
  myChartObj.Chart.ChartArea.Fill.UserPicture PictureFile:=srcPicPath
  myChartObj.Chart.Export destPicPath
  myChartObj.Delete
  Application.ScreenUpdating = True
End Sub
Chartの機能を用いてリサイズ・JPEG保存・コメントに貼付
