EXCEL2000 VBA 複数の画像ファイルをシートに挿入する 実験 [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
コメント 0