指定ディレクトリの画像全てを挿入

Sub 画像リスト()
'　画像ファイルを取得する
'　貼り付けるシート名は、「図」。
'　Sheets("図").Activate
Dim fairu_su As Long ' ファイルの数
Dim fairu() As String '　図のファイル名
Dim 図の種類 As String '　図の拡張子
Dim i As Long
Dim j As Long
Dim k As Long
Dim m As Long
Dim 表示列 As Long '　画像を表示する列数（画像を1列に〜１枚毎に下に〜貼り付けるかどうか）
Dim mes As String '
Dim パス As String 'ファイルのあるディレクトリ名
ReDim fairu(800) '　ファイル名を格納する変数の数
Dim 倍率 As Single '　画像表示の倍率

表示列 = 5
倍率 = 0.4
図の種類 = "jpg"
fairu(0) = "1"

i = 5 ' 挿入行数の初期値
j = 1 ' ファイル数のカウンター
k = 1 '　表示列用のカウンター
パス = "I:\JMTemp\"

mes = MsgBox(パス & "　ﾃﾞｨﾚｸﾄﾘの画像ﾃﾞｰﾀを表示します。" _
, vbOKCancel, "画像データ表示")
If mes = vbCancel Then End

Do
For m = 1 To 表示列
Cells(i, k).Select
If j = 1 Then fairu(1) = Dir(パス & "*." & 図の種類, vbDirectory)

If j <> 1 Then fairu(j) = Dir

If fairu(j) = "" Then End

ActiveSheet.Pictures.Insert(パス & fairu(j)).Select
' ActiveSheet.Shapes("Picture " & j).Select
Selection.ShapeRange.ScaleWidth 倍率, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.ScaleHeight 倍率, msoFalse, msoScaleFromTopLeft
k = k + Abs(Int(倍率 * -12))
j = j + 1
Next
i = i + 18
k = 1
Loop Until fairu(j) <> ""

End Sub