Excelのセルごとに図面のイメージを貼り付ける

画像の一覧をセルのサイズに合わせて貼り付ける。A列に画像、B列にファイル名、C列にリンクしたフルパスを入れている。表形式なので並び替え／ソートもできる。次図は、前もってテーブル化している。テーブル化は、プログラムではなく先に設定した。追加した分も自動でテーブルになる。

mainのコード。流れは、削除、ファイルリスト作成、画像貼り付けの順。mainプロシージャの中で以下の３つ自作のプロシージャを使っている。

1. アクティブなシート内全部削除
2. myDir
3. instertImg2Cell

Sub main()
    On Error GoTo myErr
    アクティブなシート内全部削除 '自作Subプロシージャ
    Dim s As String
    s = myDir(Sheet1.Range("e1"), Range("e2")) '自作関数
    instertImg2Cell s, Range("a2") '自作Subプロシージャ
    Exit Sub
myErr: 'ラベル
    Debug.Print Err.Number, Err.Description
    Stop 'Stopステートメントでブレークポイントを設定
    Resume 'エラーのあった行へ移動
End Sub

画像とセルデータの両方を削除する。Shapeの名前を判断して、削除している。コマンドボタンとドロップボックスは除外する。このコードの元はマクロ記録で、知りたかったのはShapes、Delete、ClearContents。

Sub アクティブなシート内全部削除()
  Dim shp As Shape
  For Each shp In Excel.ActiveSheet.Shapes
    If VBA.InStr(shp.Name, "Button") Or VBA.InStr(shp.Name, "Drop ") Then'消したく無い
    Else
        shp.Delete
    End If
  Next shp
'  Cells.Clear
    Excel.Range("A2:C3000").ClearContents
    Excel.Range("a1").Select
 End Sub

myDir関数は、このページで作った関数を使う。

instertImg2Cell プロシージャは画像を扱う目的の処理。Shapes.AddPictureで画像をセルに入れる。使い方は、引数のヒントを参考にする。引数LinkToFileはリンクファイルになる。Excelファイル開いた時点でリンク先を開こうとする。引数SaveWithDocumentは、Excelのセルに画像データを保存するかどうか、Falseにすると引数LinkToFileがTrueの時に画像ファイルを呼び込む。False、Trueを指定する引数は、列挙型になっている。Falseは、リストから選ぶとmsoFalse、Trueはリストから選ぶとmsoTrueにしている。注意点は、最後の４つの引数にRangeオブジェクトからLeft,Top,Width,Heightを取り出している。画像が入る位置のポイント単位という単位で指定する。Topは必ず下のセルに表示するために位置を指定する。全部のセルの大きさが同じことを前提にしているため他の引数Left,Width,Heightは結果的に変化していない。AddPictureはShapeコレクションのメソッドです。

AddPicture( Filename, LinkToFile, SaveWithDocument, Left, Top, Width, Height )

画像の横にファイル名を、ActiveSheet.Hyperlinkでフルパスのハイパーリンクを入れる。

Sub instertImg2Cell(files As String, rStart As Range)
    Dim bb, rMove As Range
    bb = Split(files, vbCrLf) 'ファイル名の配列にする
    rStart.Select 'スタートのセルを選択
    Set rMove = rStart
    Dim i As Integer
    For i = 0 To UBound(bb)
        If 0 <> Len(bb(i)) Then
            ActiveCell.Offset(0, 1) = getFileName(bb(i))
            ActiveSheet.Hyperlinks.Add ActiveCell.Offset(0, 2), bb(i) 'ハイパーリンクで挿入
            Sheet1.Shapes.AddPicture ActiveCell.Offset(0, 2), msoTrue, msoTrue, rMove.Left, _
            rMove.Top, rMove.Width, rMove.Height  '画像の挿入
            Debug.Print rMove.Top 'Topだけは変わるので、挿入位置が変わる
            Set rMove = rMove.Offset(1, 0) 'AddPicture用のセル位置
            ActiveCell.Offset(1, 0).Select '次のセルへ
        End If
    Next
End Sub
'instertImg2Cell mydir(thisworkbook.Path,"*.png"), Range("a2")

マクロ記録で画像をセルに入れると、Pictures.Insert メソッドになる。「Pictures insert」で検索するとMicrosoftサポートでShapes. AddPictureメソッドを使うことが推奨されていた。Pictures.Insert メソッドの方が引数が少ないので使い方は簡単で、同様に動作するがここではAddPictureを使った。

フルパスからファイル名だけを取り出す関数。

Function getFileName(fullPathName) As String
    Dim ar
    ar = VBA.Split(fullPathName, "\")
    getFileName = ar(UBound(ar)) '配列の最後がファイル
End Function

以下は、イミディエイトウィンドウでgetFileNameを確認している。

?vba.CurDir
C:\Users\take\Documents
?getfilename(vba.CurDir)
Documents

Private Sub Workbook_Open()
    Sheet1.Range("f1") = VBA.Environ("homedrive") & VBA.Environ("homepath") & "\desktop"
    Sheet1.Range("f2") = VBA.Environ("homedrive") & VBA.Environ("homepath") & "\documents"
    Sheet1.Range("f3") = "c:\windows\system32"
End Sub

C列の画像データのファイルはリンクが張られている。 このハイパーリンクが開けないことがある。リンク先をクリックして以下のエラーが出たらpngの拡張子に対して使うアプリが正しく無い可能性がある。Windowsはファイルをクリックしてファイルの拡張子ごとにアプリを開く機能のある。

スマホの方は、ここをクリックするYouTubeで見れます。

私の場合は、原因はわからないが、アプリのインストール時に拡張子に対応するアプリを登録、その後アプリをアンインストールしたか何かだろう。png、jpg、gifが該当のアプリ無しで次の図のエラー。bmpはペイントブラシが起動した。ペイントブラシがあるので基本的に png、jpg、gif もペイントブラシが起動してくれればいいいがエラーになる。

regeditを実行して

私の場合は、選択しているpngを削除したらペイントブラシが起動できるようになる。レジストリの変更や削除は危険なのでおすすめはしない。 pngをpng123とか適当な名前に変えたらペイントブラシが起動するはず。 でも、削除方式をしたので名前変更方式は未確認。