EXCEL2000 VBA 選択範囲に合わせて画像の挿入 実験

EXCEL2000 VBA  選択範囲に合わせて画像の挿入　実験

参照サイト　ttp://worldcafe-emanon.blogspot.jp/2011/06/excel.html

シートイベントじゃなく、汎用性のあるマクロに書き換えた。（シートイベントでも利用価値はある）

 

再生できない場合、ダウンロードは🎥こちら

 

Option Explicit

---

 

Sub 選択範囲に合わせて画像挿入()

'下の改造

'ttp://worldcafe-emanon.blogspot.jp/2011/06/excel.html

 

   Dim myPic                '画像ファイル

   Dim myRange As Range '画像を配置する範囲

   Dim rX As Double

   Dim rY As Double

 

    On Error GoTo owari     'キャンセルが押されたら

 

'画像ファイルを選択

    myPic = Application.GetOpenFilename("画像ファイル,*.jpg;*.jpeg;*.gif;*.tif")

    Set myRange = Selection 'このセル範囲に収まるように画像を縮小する

 

'画面の描画停止

    'Application.ScreenUpdating = False

 

'画像サイズ

    With ActiveSheet.Pictures.Insert(myPic).ShapeRange

        rX = myRange.Width / .Width         'セルの幅と読み込んだ画像の比率　横比率

        rY = myRange.Height / .Height       'セルの幅と読み込んだ画像の比率　縦比率

            If rX > rY Then

                .Height = .Height * rY

              Else

                 .Width = .Width * rX

            End If

 

        .Left = .Left + (myRange.Width - .Width) / 2 '写真を横方向の中央に配置

        .Top = .Top + (myRange.Height - .Height) / 2 '写真を縦方向に中央に配置

    End With

'画面描画

    Application.ScreenUpdating = True

owari:

End Sub