[[20210301103255]]　『画像ファイルのリンクを切って埋め込みにしたい』（みゆ）　ページの最後に飛ぶ

『画像ファイルのリンクを切って埋め込みにしたい』（みゆ）

はじめまして、お世話になります。

VBA初心者です。

大量の画像ファイルをExcelに貼り付けたく、ネットで見つけた下記コードを利用させていただきました。

感動するほど気持ちよく添付されたのですが、リンク付き画像になってしまいました。

pasete Image に置換してみましたが、VBAの知識がなく、自分用にうまくアレンジできず困っています。

リンクを切った状態で貼付けるか、貼り付けた後リンクを切るかしたいのですが、どなたかご教授いただけないでしょうか？
よろしくお願いいします。

Sub 複数の画像を挿入()

    Dim strFilter As String
    Dim Filenames As Variant
    Dim PIC       As Picture

    ' 「ファイルを開く」ダイアログでファイル名を取得
    strFilter = "画像ファイル(*.jpg;*.jpeg;*.gif;*.bmp;*.png),*.jpg;*.jpeg;*.gif;*.bmp;*.png"
    Filenames = Application.GetOpenFilename( _
                    FileFilter:=strFilter, _
                    Title:="図の挿入(複数選択可）", _
                    MultiSelect:=True)
    If Not IsArray(Filenames) Then Exit Sub

    ' ファイル名をソート
    Call BubbleSort_Str(Filenames, True, vbTextCompare)

    ' 貼り付け開始セルを選択
    'ActicveCellRange("A3").Select

    ' マクロ実行中の画面描写を停止
    Application.ScreenUpdating = False
    ' 順番に画像を挿入
    For i = LBound(Filenames) To UBound(Filenames)
        Set PIC = ActiveSheet.Pictures.Insert(Filenames(i))

        '-------------------------------------------------------------
        ' 画像の各種プロパティ変更
        '-------------------------------------------------------------
        With PIC
            .Top = ActiveCell.Top        ' 位置：アクティブセルの上側に重ねる
            .Left = ActiveCell.Left      ' 位置：アクティブセルの左側に重ねる
            .Placement = xlMove          ' 移動するがサイズ変更しない
            .PrintObject = True          ' 印刷する
        End With
        With PIC.ShapeRange
            .LockAspectRatio = msoTrue   ' 縦横比維持
            ' 画像の高さをアクティブセルにあわせる
            ' 結合セルの場合でも対応
            .Height = ActiveCell.MergeArea.Height
            .Width = ActiveCell.MergeArea.Width
        End With

        ' 次の貼り付け先を選択（アクティブセルにする）[例：13個下のセル]
        ActiveCell.Offset(13).Select

        Set PIC = Nothing
    Next i

    ' 終了
    Application.ScreenUpdating = True
    MsgBox i - 1 & "枚の画像を挿入しました", vbInformation

End Sub

' バブルソート（文字列）
Private Sub BubbleSort_Str( _

    ByRef Source As Variant, _
    Optional ByVal SortAsc As Boolean = True, _
    Optional ByVal Compare As VbCompareMethod = vbTextCompare)

    If Not IsArray(Source) Then Exit Sub

    Dim i As Long, j As Long
    Dim vntTmp As Variant
    For i = LBound(Source) To UBound(Source) - 1
        For j = LBound(Source) To LBound(Source) + UBound(Source) - i - 1
            If StrComp(Source(IIf(SortAsc, j, j + 1)), _
                       Source(IIf(SortAsc, j + 1, j)), Compare) = 1 Then
                vntTmp = Source(j)
                Source(j) = Source(j + 1)
                Source(j + 1) = vntTmp
            End If
        Next j
    Next i

End Sub

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

 こうじゃないですか？

 Sub 複数の画像を挿入()
     Dim strFilter As String
     Dim Filenames As Variant
     Dim i As Long               '■追加
     Dim rng As Range            '■追加

     Dim pic As Shape            '■修正
     ' 「ファイルを開く」ダイアログでファイル名を取得
     strFilter = "画像ファイル(*.jpg;*.jpeg;*.gif;*.bmp;*.png),*.jpg;*.jpeg;*.gif;*.bmp;*.png"
     Filenames = Application.GetOpenFilename( _
                 FileFilter:=strFilter, _
                 title:="図の挿入(複数選択可）", _
                 MultiSelect:=True)
     If Not IsArray(Filenames) Then Exit Sub

     ' ファイル名をソート
     Call BubbleSort_Str(Filenames, True, vbTextCompare)

     ' 貼り付け開始セルを選択
     Set rng = Range("A3")
     'ActicveCellRange("A3").Select  '■不明

     Application.ScreenUpdating = False

     ' 順番に画像を挿入
     For i = LBound(Filenames) To UBound(Filenames)
         Set pic = ActiveSheet.Shapes.AddPicture(Filenames(i), False, True, _
                                                 rng.Left, rng.Top, -1, -1)  '■修正
         '-------------------------------------------------------------
         ' 画像の各種プロパティ変更
         '-------------------------------------------------------------
         With pic
             ' .LockAspectRatio = msoTrue   ' 縦横比維持　自動的にmsoTrueになるので不要
             ' 画像の高さをアクティブセルにあわせる
             ' 結合セルの場合でも対応
             '.Height = rng.MergeArea.Height  ' 下のコードで幅が優先されるので意味なし。
             .Width = rng.MergeArea.Width
             .Placement = xlMove              ' 移動するがサイズ変更しない
         End With

         ' 次の貼り付け先を選択
         Set rng = rng.Offset(13)
         Set pic = Nothing
     Next i
     ' 終了
     Application.ScreenUpdating = True
     MsgBox i - 1 & "枚の画像を挿入しました", vbInformation
 End Sub

 (1)画像の挿入先を、ActiveCellというよりも、Range型変数にしたほうがよいと思う。
 (2)また、その初期値が指定していないので、たまたまActiveであったセルから
    開始してしまいますよ。きちんと指定したほうがよいでしょう。
    いや意図的にそうしたい、というなら Set rng = Selection としてください。
 (3)   
    .LockAspectRatio = msoTrue(縦横比を固定）
    したのであれば、
    .Height = ActiveCell.MergeArea.Height
    は無駄で、
    .Width = ActiveCell.MergeArea.Width
    だけが効果を持つことになりますよ。
    つまり、セル幅に合わせて、高さは合わせない、ということでいいんですね？

（γ） 2021/03/01(月) 14:42

Y様

お返事ありがとうございます！
コードまで修正していただいて、本当に助かります。

(2)Active セルからスタートさせたい意思がありました。

 Set rng = Selection 　やってみますね。

(3)縦長の写真がはみ出さないように高さにも条件をつけたつもりでした。

急ぎの案件が入ってしまったので、後ほどゆっくり試させていただきますね。
取り急ぎお礼まで。

（みゆ） 2021/03/01(月) 16:28

コメント返信：

[ 一覧(最新更新順) ]

[[20210301103255]] 『画像ファイルのリンクを切って埋め込みにしたい』（みゆ） ページの最後に飛ぶ

[[20210301103255]]　『画像ファイルのリンクを切って埋め込みにしたい』（みゆ）　ページの最後に飛ぶ