Ｅｘｃｅｌ マクロ 画像をリンクせずかつ圧縮して貼りつける方法を教えてください

お手数おかけしますが、ご教示ください。
Ｅｘｃｅｌ2013を使用しています。
マクロのことはほとんどわかりませんが、ネット情報から、下記のマクロを作成しました。
ただ、元の画像を消去したり、メールで送ったりすると、リンクされていないため画像が表示されず、行き詰っています。
そこで、画像を貼りつけるマクロ、さらに欲を言えば、その画像を印刷用（220ppi）の解像度に圧縮した上で貼りつけるマクロがありましたら、下記のマクロをどのように変更したらいいのでしょうか？
丸投げで申し訳ありませんが、お力をお貸しください。よろしくお願いします。


Sub 画像()

Dim fName, pict As Picture

fName = Application.GetOpenFilename("JPG,*jpg", MultiSelect:=True)

If IsArray(fName) Then

For i = 1 To UBound(fName)

Set pict = ActiveSheet.Pictures.Insert(fName(i))

pict.Width = 360

pict.Height = 180

ActiveCell.Offset(1, 1).Activate

Next i

End If

End Sub

No.1 回答者： Qchan1962 回答日時： 2020/06/01 02:39

ご質問を読んだ感じですと、どうされたいのかわかりません。

示されているコードで画像は貼り付くと思いますが、
＞ただ、元の画像を消去したり、メールで送ったりすると、リンクされていないため画像が表示されず、行き詰っています。
そういう事ですね。

ActiveSheet.Pictures.Insertを　ActiveSheet.Shapes.AddPictureにすれば、リンク貼り付けでなくなります。
Shapesなのでオブジェクト型も変わります

ご質問のコードの改造

Sub 画像()
Dim fName, pict As Shape
Dim i As Integer
　 fName = Application.GetOpenFilename("JPG,*jpg", MultiSelect:=True)
　 If IsArray(fName) Then
　　 For i = 1 To UBound(fName)
　　　　Set pict = ActiveSheet.Shapes.AddPicture( _
　　　　　　　 Filename:=fName(i), _
　　　　　　　 LinkToFile:=False, _
　　　　　　　 SaveWithDocument:=True, _
　　　　　　　 Left:=Selection.Left, _
　　　　　　　 Top:=Selection.Top, _
　　　　　　　 Width:=360, _
　　　　　　　 Height:=180)
　　　　ActiveCell.Offset(1, 1).Activate
　　 Next i
　 End If
End Sub


変数　i　が　宣言されていないので
Dim i As Integer を上に加える
Dim fName, pict As Picture　を　Dim fName, pict As Shape

最初に貼り付ける場所の指定とかも必要かもしれませんが、
選択されているセルに最初に貼り付き、複数画像を選んでいれば、一つ下の一つ右に次の画像が挿入されると思いますよ。（そのまま）


＞印刷用（220ppi）の解像度　：については、Excelのデフォルト設定なので変更しなくて良いのではないでしょうか。

No.2 ベストアンサー 回答者： Qchan1962 回答日時： 2020/06/01 15:38

＃１です。

＞印刷用（220ppi）の解像度　：については、Excelのデフォルト設定なので変更しなくて良いのではないでしょうか。
上記のように回答しましたが、Shapes.AddPicture を実行しサイズを変更した場合、解像度が変更されるため上記回答は、
誤りだと思いますので、訂正いたします。

サイズを変更せず、Shapes.AddPictureを実行しその後Resizeする処理に変えました。
アスペクト比を維持するため、高さのみ指定しています。
サンプル（ご希望のものになるか分かりません。）
Sub 画像1()
　 Dim fName, pict As Shape
　 Dim i As Integer
　 fName = Application.GetOpenFilename("JPG,*jpg", MultiSelect:=True)
　 If IsArray(fName) Then
　　 For i = 1 To UBound(fName)
　　　　Set pict = ActiveSheet.Shapes.AddPicture( _
　　　　　　 fName(i), _
　　　　　　 msoFalse, msoTrue, Selection.Left, Selection.Top, -1, -1)　'-1 =size維持
　　　　　　 pict.Height = 180 'resize
　　　　ActiveCell.Offset(1, 1).Activate
　　 Next i
　 End If
End Sub

画像詳細が不明なので、他の方法で解像度によるサイズ指定を行う場合は、下記をどうぞ
参考サイト　：https://qiita.com/shela/items/d20fd84a82d930b5804e

この回答へのお礼

Qchan1962様

　貴重なお時間を割いて頂き、２度にわたる丁寧なご回答ありがとうございます。
　回答頂いたコードで先ほど作業してみたところ、まさに望みどおりにできました。
　感謝感激です。
　本当にありがとうございました。

お礼日時：2020/06/01 21:59