EXCEL2000 VBA 複数の画像ファイルをシートに挿入する 実験

EXCEL2000 VBA  複数の画像ファイルをシートに挿入する　実験

 

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

 

Sub 複数画像挿入()

'ダイアログを開き複数のファイルを選択して画像を挿入する

'画像はセル幅に合わせる

 

   Dim myPic                '画像ファイル

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

   Dim rX As Double

   Dim rY As Double

   Dim i As Long

   Dim SrowCont As Long

 

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

 

'画像ファイルを複数選択　True指定

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

'選択範囲を調べる

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

    SrowCont = Selection.Rows.Count  '選択範囲行数

 

'画面の描画停止

    'Application.ScreenUpdating = False

 

'選択した画像ファイル数だけループ

 

    For i = LBound(myPic) To UBound(myPic)

    '画像サイズ

        With ActiveSheet.Pictures.Insert(myPic(i)).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

         '挿入する画像の位置を下に移動（1行分を足す）

            ActiveCell.Offset(SrowCont + 1).Activate

    Next i

'画面描画

    Application.ScreenUpdating = True

owari:

End Sub

 

 

 

タグ：Excel2000 VBA