Excelでコメントにクリップボードの画像を追加するマクロ

先日Excelでコメントに画像を追加する記事を書いたのだが、、、
後々調べるとすでに同様の記事があるじゃないか。

atz.hatenadiary.com

まあ、自分が思いつくことぐらい他の人も考えるわけで、腐らずに頑張ってくしかない！
そんな訳で今回は前回からの追加機能としてクリップボードにコピーした画像をコメントに追加するマクロを作成してみた。

というのもwindows10になって画面キャプチャー機能が充実。
必要な範囲だけをキャプチャしてくれるWin＋SHIFT＋"S"が便利で、私も多用している。
特にAIリストの管理なんかに文字データだけだと記憶に残らないけど、
画像もあると一発で思い起こせたり、複数人と共有する場合では認識の齟齬が生じにくい。
かといって画像のまま貼るとセルを画像サイズよって拡張したり、行がずれたりで見た目が美しくない。

そうなるはやることは明確でキャプチャ→Excelのコメントにキャプチャ画像を追加をVBAで実現する。
しかし、一つハードルとしてキャプチャをダイレクトでコメント画像には設定できない（もし方法あれば、素人の私に教えてほしい）。
したがって、キャプチャを画像ファイルとして保存→保存したデータを読み込みというステップを踏んだ。

結果としては下記のマクロを作った（ネットにある先人たちのマクロの組み合わせ）。
2020/07/19修正　名前をつけて保存した画像を再度選ぶプロセスを削除。

Sub PictureSave()
Sub comment_image2()
  Dim arBuf As Variant
  Dim cb As Variant
  Dim sh As Worksheet
  Dim pic As Object
  Dim objCht As Object
  Dim Fname As String
  Dim formatDate As String
  Dim pic2
  Dim PicType
  Dim IMG As Object


  Set sh = Worksheets.Add '空のシート
  arBuf = Application.ClipboardFormats
  If Not IsArray(arBuf) Then MsgBox "クリップボードに何もありません。": Exit Sub
  For Each cb In arBuf
    If cb = xlClipboardFormatBitmap Then
      ActiveSheet.Paste
      Exit For
    End If
 Next
  
  Set pic = ActiveSheet.Pictures(1)
  If pic Is Nothing Then Exit Sub
  Set objCht = ActiveSheet.ChartObjects.Add(pic.Left, pic.Top, pic.Width, pic.Height).Chart
    objCht.Parent.Select
    objCht.Paste
  
  
  formatDate = Format$(Now(), "yymmdd_hhmmss")
  Fname = Application.GetSaveAsFilename(formatDate, "画像ファイル(*.jpg), *.jpg", , "画像の保存")
  
  If VarType(Fname) = vbBoolean Then Exit Sub
  
  pic.Copy
  objCht.Paste
  objCht.Export Fname, "jpg"
  pic.Delete
  
  sh.ChartObjects(1).Delete
  Application.DisplayAlerts = False
  ActiveSheet.Delete  'シート削除
  Application.DisplayAlerts = True


ActiveCell.ClearComments

'PicType = "画像ファイル,*.jpg;*.bmp;*.png;*.gif," & _
            "jpgファイル,*.jpg,bmpファイル,*.bmp,pngファイル," & _
            "*.png,gifファイル,*.gif"
'pic2 = Application.GetOpenFilename(PicType, , "挿入する画像を選択", , False)


Set IMG = LoadPicture(Fname)
With ActiveCell.AddComment
    .Shape.Fill.UserPicture Fname
    .Shape.Height = Application.CentimetersToPoints(IMG.Height) / 1000
   .Shape.Width = Application.CentimetersToPoints(IMG.Width) / 1000
    .Visible = True
End With

End Sub

ちなみにコメント表示/非表示/削除もショートカットキーを割り当てると快適。

以上