Excelへ写真を貼り付けるマクロ

これはいい！

Excelのワークシートへ写真の挿入、貼り付けが画像をクリックするだけで位置・サイズ調整・圧縮まで行うことが出来るすぐれものマクロ

一度に３枚まで連続操作が出来るが途中でキャンセルできる為一枚でも正常に動作します

Range("A1,A21,A41")　を増やせば３枚以上もOK

Excelを閉じる時にCPUが１００％になり大変遅いため、ダミーのコピー処理を追加してクリップボードを空にしている

以下のオリジナルから改造<m(__)m>

http://park7.wakwak.com/~efc21/cgi-bin/exqalounge.cgi?print+200802/08020023.txt

 

Sub 写真貼り付け()
    Dim vntFileName As Variant
    Dim i As Integer
    Dim int総数 As Integer
    Dim rng挿入先 As Range
    Dim rng全挿入先 As Range
    ActiveWindow.Zoom = 100
    Set rng全挿入先 = Range("A1,A21,A41")
    int総数 = rng全挿入先.Areas.Count
    For Each rng挿入先 In Range("A1,A21,A41")
        i = i + 1
        vntFileName = Application.GetOpenFilename( _
            FileFilter:="写真 (*.bmp;*.jpg;*.tif;*.jpeg;*.png),*.bmp;*.jpg;*.tif;*.jpeg;*.png", _
            Title:="挿入する写真を選択 (" & CStr(i) & " of 3)", MultiSelect:=False)
        If VBA.VarType(vntFileName) <> vbString Then Exit For
        With ActiveSheet.Pictures.Insert(vntFileName)
            .Top = rng挿入先.Top
            .Left = rng挿入先.Left
            .Cut
            rng挿入先.Select
'            ActiveSheet.PasteSpecial Format:="図 (BMP)", Link:=False, DisplayAsIcon:=False
            ActiveSheet.PasteSpecial Format:="図 (JPEG)", Link:=False, DisplayAsIcon:=False
             Selection.ShapeRange.Height = 252# 'DSC(Lサイズ相当) 89×119
             Selection.ShapeRange.Width = 337.5  '
             Selection.ShapeRange.Rotation = 0#
            Application.CutCopyMode = False
            Range("A1").Copy 'クリップボードの画像を消去する為の上書き・ダミーコピー
            Application.CutCopyMode = False
        End With
    Next
End Sub