Excel VBA セルのコメントに画像を埋め込み簡易ビューアーにする


サンプルでは任意のセルにコメントを挿入し、ダイアログで指定した画像を埋め込みます。ついでに、ビューアーで開けるように保存場所のリンクを挿入します。

使い方

1. コメントを挿入したいセルを選択する。連続セルでも離れたセルでもOK。

2. マクロを実行

3.ファイルを開くダイアログから、対応する画像を選択する。

4. 選択したセルにコメントが挿入され、画像が埋め込まれる。

5. 標準ビューアーで開くためのハイパーリンクが右端の列に挿入される。

6.終了

ポイント

1. 連続セルと離れたセルが混在した選択範囲に対応。もっとエレガントな方法があれば嬉しい。

2. 画像ファイルは名称を基準に変数に保存される。別のダイアログなら選択順に保存されるのだろうか。

3.扱う画像の数が増えると、ファイルサイズが大きくなる。実用性を考えれば、セルにフォーカスした時とフォーカスが離れたときにコメント・画像を挿入/削除する処理をした方がよい。

ソースコード

Const commentColumn As Integer = 1 'コメントを挿入する列 Const imagePathColumn As Integer = 3 '画像パス(リンク)を挿入する列 Const imageMaxWidth As Double = 200 'コメントの幅 Const pixelPointRatio As Double = 0.0378 'ピクセル-ポイント変換比率

Sub InsertImageAsComment() Dim obj As Variant Dim selectedRangeArray() As Range Dim counterIndex As Long '連続セルと非連続セル両方に対応できるように For Each obj In Selection ReDim Preserve selectedRangeArray(counterIndex) Set selectedRangeArray(counterIndex) = obj counterIndex = counterIndex + 1 Next 'ファイルを開くダイアログ(フィルター有り、複数選択可)で画像を選択する Dim imagePathArray As Variant imagePathArray = Application.GetOpenFilename(FileFilter:="JPEG 形式, *.jpg", MultiSelect:=True) If IsArray(imagePathArray) = False Then Exit Sub

'選択されたセルの数だけ繰り返す For counterIndex = 0 To UBound(selectedRangeArray) Dim currentRange As Range: Set currentRange = selectedRangeArray(counterIndex) '選択された画像の数より選択されたセルの数が多い場合は、抜ける If UBound(imagePathArray) < counterIndex + 1 Then Exit Sub currentRange.Comment.Delete 'コメントを追加する。画像を読み込み、サイズを取得する。 Dim currentComment As Comment: Set currentComment = currentRange.AddComment Dim sourceImagePath As String: sourceImagePath = imagePathArray(counterIndex + 1) Dim sourceImage As Object: Set sourceImage = LoadPicture(sourceImagePath) Dim sourceImageWidth As Double: sourceImageWidth = sourceImage.Width Dim sourceImageHeight As Double: sourceImageHeight = sourceImage.Height With currentComment.Shape On Error Resume Next 'コメントに画像を貼り付ける .Fill.UserPicture (sourceImagePath) '画像の大きさに合わせてコメントのサイズを設定する 'とりあえず、横幅は最大で200までにする If sourceImageWidth * pixelPointRatio <= imageMaxWidth Then .Width = sourceImageWidth * pixelPointRatio .Height = sourceImageHeight * pixelPointRatio Else .Width = imageMaxWidth .Height = imageMaxWidth * sourceImageHeight / sourceImageWidth End If End With '画像をビューアーでも開けるよう、リンクを張る ActiveSheet.Hyperlinks.Add _ Anchor:=currentRange.Offset(0, imagePathColumn - commentColumn), _ Address:=sourceImagePath, _ ScreenTip:=sourceImagePath, _ TextToDisplay:="ビューワーで開く" Next End Sub

#ハイパーリンク #コメント #ExcelVBA #画像