【Excel】画像自動貼り付け – Un Known…(跡地) 技術メモ

フォルダ内のJPGファイルをフォルダごとのシートを作成し、
そのシート内に自動で貼り付けします。
1Sub JpgPut()
2 
3' JpgPut
4' JPGファイルを貼り付ける。
5' エビデンスが存在する1階層上のフォルダを指定する。(末尾\)
6' フォルダ内のJPGファイルは100枚まで。
7' 例)
8' C:\work\ebi\を指定した場合、
9' C:\work\ebi\imgフォルダ内のJPGファイルを貼り付ける。
10 
11    Application.Calculation = xlCalculationManual
12    Application.EnableEvents = False
13    Application.ScreenUpdating = False
14    Application.DisplayStatusBar = True
15    Application.StatusBar = "処理中・・・"
16     
17    Dim count As Integer
18    count = 0
19    Dim folderPath As String ' 環境によって変更すること。
20    folderPath = Worksheets(1).Cells(2, 1).Value
21     
22    Dim fileName As String
23    fileName = Dir(folderPath & "\", vbDirectory)
24     
25    Dim n As Integer
26    n = 0
27     
28    Dim fileNames(100) As String
29    Do While fileName <> ""
30        fileNames(n) = fileName
31        n = n + 1
32        fileName = Dir()
33    Loop
34     
35    Dim i As Integer
36    Dim j As Integer
37    For j = 0 To n
38        fileName = fileNames(j)
39        If GetAttr(folderPath & "\" & fileName) And vbDirectory Then
40            If fileName <> "." And fileName <> ".." And fileName <> "" Then
41                i = 0
42                Dim newSheet As Worksheet
43                Set newSheet = Worksheets.Add()
44                newSheet.Move after:=Worksheets(Worksheets.count)
45                newSheet.Name = fileName
46                 
47                Dim jpgPath As String
48                jpgPath = Dir(folderPath & "\" & fileName & "\" & "*.JPG", vbNormal)
49                Do While jpgPath <> ""
50                 
51                    ' 画像の高さに合わせて「45」の数値を変更すること。
52                    newSheet.Cells(i * 45 + 1, 1).Value = jpgPath
53                    newSheet.Cells(i * 45 + 2, 2).Select
54                     
55                    ' Excel2010の場合はここから
56                    ' 画像を1*1ポイントで貼り付け
57                    Set myShape = Worksheets(fileName).Shapes.AddPicture( _
58                    fileName:=folderPath & "\" & fileName & "\" & jpgPath, _
59                    linkToFile:=False, _
60                    saveWithdocument:=True, _
61                    Left:=Selection.Left, _
62                    Top:=Selection.Top, _
63                    Width:=msoTrue, _
64                    Height:=msoTrue)
65                    ' 画像を元のサイズに変換(Heightの設定は不要かも)
66                    ' Withを利用しないとオブジェクトエラーになる。
67                    With myShape
68                        LockAspecRatio = msoTrue
69                        Hieght = 560
70                    End With
71                    'myShape.LockAspecRatio = msoTrue
72                    'myShape.Hieght = 560
73                    ' Excel2010の場合はここまで
74                     
75                    ' Excel2013の場合はここから
76                    'Worksheets(fileName).Picutures.Insert fileName:=folderPath & "\" & fileName & "\" & jpgPath
77                    ' Excel2013の場合はここまで
78                     
79                    i = i + 1
80                    count = count + 1
81                    jpgPath = Dir()
82                Loop
83                 
84            End If
85        End If
86    Next j
87     
88    Application.StatusBar = count & "個貼り付け完了"
89    Application.ScreenUpdating = True
90    Application.EnableEvents = True
91End Sub