[[20190309175240]]　『画像一覧表示（Shapes.Add メソッド）』（AURYU）　ページの最後に飛ぶ

『画像一覧表示（Shapes.Add メソッド）』（AURYU）

はじめて投稿させていただきます。
VBAについて無知のものですが、できましたら教えていただけますと
大変助かります。よろしくお願いします。

【質問内容】
エクセルで画像ファイル名（必要ならパス含む）一覧を作り、
その横にセルの枠に収まるように画像を挿入させて画像一覧の表を作りたいです。
画像は使わないものも含めて全て同じフォルダに入っています。
下記のコードを見つけ、試してみたところ、希望通りのことができましたが、
他のPCで画像が表示されず、困っています。
リンクとして挿入されているので、他PCで共有できないから「Shapes.Add メソッド」を使用してください。と検索では出てきたのですが、コードを編集できるほど知識がないので、お力をお貸しいただけませんでしょうか？

ーーー↓見つけたVBAですーーー

Sub 画像挿入リンク()

Application.OnKey "^%{B}", "image_paste"
End Sub
Function image_paste()
Dim w_address As String
Dim hako As Variant
Dim i As Long
Dim start_row
Dim start_column
w_address = Selection.Address
start_row = Selection(1).Row
start_column = Selection(1).Column

hako = Selection
If Selection.Count = 1 Then

    If hako <> "" Then
        If IsError(hako) = False And IsNumeric(hako) = False Then
            If Dir(hako) <> "" Then
                    ActiveSheet.Pictures.Insert(hako).Select
                    Selection.Left = Range(Cells(start_row + i - 1, start_column + 1), Cells(start_row + i - 1, start_column + 1)).Left
                Selection.Top = Range(Cells(start_row + i - 1, start_column + 1), Cells(start_row + i - 1, start_column + 1)).Top
            End If
        End If
    End If
Else
    For i = 1 To UBound(hako)
        If IsError(hako(i, 1)) = False And IsNumeric(hako(i, 1)) = False Then
            If Dir(hako(i, 1)) <> "" Then

                ActiveSheet.Pictures.Insert(hako(i, 1)).Select
                Selection.Left = Range(Cells(start_row + i - 1, start_column + 1), Cells(start_row + i - 1, start_column + 1)).Left
                Selection.Top = Range(Cells(start_row + i - 1, start_column + 1), Cells(start_row + i - 1, start_column + 1)).Top
            End If
        End If
    Next i
End If
Range(w_address).Select
End Function

End Function

ーーーここまでーーー

以上です。
よろしくお願いします。

＜使用 Excel：Excel2010、使用 OS：Windows10 ＞

＞その横にセルの枠に収まるように画像を挿入

＞試してみたところ、希望通りのことができましたが、

本当ですか？

（マナ） 2019/03/09(土) 18:54

修正しようと思ったのですが
結局全面書き換えです。

 Option Explicit

 Sub test()
    Dim c As Range
    Dim r As Range

    For Each c In Selection
        If Dir(c.Value) <> "" Then
            Set r = c.Offset(, 1)

            With ActiveSheet.Shapes.AddPicture( _
                        Filename:=c.Value, _
                        LinkToFile:=False, SaveWithDocument:=True, _
                        Left:=r.Left, Top:=r.Top, _
                        Width:=-1, Height:=-1)

                If r.Width / .Width < r.Height / .Height Then
                    .Height = .Height * r.Width / .Width
                    .Top = r.Top + (r.Height - .Height) / 2
                Else
                    .Width = .Width * r.Height / .Height
                    .Left = r.Left + (r.Width - .Width) / 2
                End If
            End With
        End If
    Next

 End Sub

（マナ） 2019/03/09(土) 19:55

マナさん

いただいたもので試してみたところ、理想通りの結果になりました。
大変助かりました！
お早い回答ありがとうございました！
（AURYU） 2019/03/09(土) 20:25

コメント返信：

[ 一覧(最新更新順) ]

[[20190309175240]] 『画像一覧表示（Shapes.Add メソッド）』（AURYU） ページの最後に飛ぶ

[[20190309175240]]　『画像一覧表示（Shapes.Add メソッド）』（AURYU）　ページの最後に飛ぶ