'18/05/19更新:フォルダ名/ファイル名の並びを各々ソートして取得する仕様にコードを更新した。
本プログラムは、main関数を指定して実行するとダイアログが表示されるので、下図のように画像ファイルがあるサブフォルダの親フォルダの箇所でOKを押す。ちなみに、画像ファイルの取得方法には拡張子.jpgを指定しているため、各フォルダ内に画像ファイル以外のファイルが存在しても動作に支障はない。
すると、下図のように「画像一覧」シートの1行目にサブフォルダ名を記載し、それら各列に各サブフォルダ内の画像が貼り付けられる。ちなみに、F列のPCcase_geforceは空なのは、フォルダ内に画像がないためである。
また、下図のように「ファイル名一覧」のシートに取得したファイル名を記載する仕様である。
▼本プログラム('18/05/19更新)
あらかじめ、Excelシート「画像一覧」と「ファイル名一覧」を作成する(上図の左下のように)。これは、画像貼り付けやファイル名などを書き込むシート名をコード内で指定しているためである。そして、実行にはmain関数を指定してマクロ実行すれば良い。ちなみに、画像のアスペクト比を保ちたければ、.LockAspectRatio = False箇所のFalseをTrueにすれば良い。
Option Explicit '変数を必ず宣言する意 'ソートのためのAPI読み出し宣言 Declare PtrSafe Function StrCmpLogicalW Lib "SHLWAPI.DLL" _ (ByVal lpStr1 As String, ByVal lpStr2 As String) As Long '空配列の判定のためのAPI読み出し宣言 Declare Function SafeArrayGetDim Lib "oleaut32" _ (ByRef psa() As Any) As Long 'Publicはローカル変数でなく、グローバル変数の意味 '他のモジュールでも使用できる。例えばフォームモジュール等 Public myfolder As String Public mySubfld(), myfname() As Variant Public myfileNmax As Integer Public セル行の高さ, セル列の幅, 表のフォント As Long Sub main() 'main関数:フォームに登録する場合はここを指定する。 Dim n, cnt, i, j As Integer ' =====パラメータ===== セル行の高さ = 85 セル列の幅 = 17.5 表のフォント = 10 '===================== Application.ScreenUpdating = False ' 初期化(すでに貼り付けられてる画像ファイルなどの消去) ThisWorkbook.Worksheets("ファイル名一覧").Activate Call 全セルクリア Range("A1").Select Worksheets("画像一覧").Activate Call 全セルクリア Call 全画像クリア Call フォルダ指定 Call サブフォルダ一覧取得 ' 画像貼り付け表の作成 cnt = 1 myfileNmax = 1 For n = 1 To UBound(mySubfld) Call フォルダ内ファイル取得(n) If SafeArrayGetDim(myfname) <> 0 Then cnt = UBound(myfname) End If If myfileNmax <= cnt Then myfileNmax = cnt End If Erase myfname Next n myfileNmax = myfileNmax - 1 'サブフォルダ内にあるファイルの最大数 Debug.Print myfileNmax Call 画像貼り付け表作成 j = 2 For n = 1 To UBound(mySubfld) Cells(1, j) = mySubfld(n) j = j + 1 Next n For i = 1 To myfileNmax + 1 Cells(i + 1, 1) = i Next i ' ファイル名入力と画像貼り付け j = 2 For n = 1 To UBound(mySubfld) Call フォルダ内ファイル取得(n) Worksheets("ファイル名一覧").Select Cells(1, j) = mySubfld(n) If SafeArrayGetDim(myfname) <> 0 Then For i = 2 To UBound(myfname) + 1 Cells(i, 1) = i - 1 Cells(i, j) = myfname(i - 1) Next i Worksheets("画像一覧").Select Call 画像貼り付け(j) End If Erase myfname() 'フォルダ毎に処理してるため、一旦空にする j = j + 1 Next n Worksheets("画像一覧").Activate Range("A1").Select Application.ScreenUpdating = True End Sub Sub バブルソート_API(ByRef myArray() As Variant) Dim i, j As Long Dim tmp As String For i = LBound(myArray) To UBound(myArray) For j = i To UBound(myArray) If StrCmpLogicalW(StrConv(myArray(i), vbUnicode), StrConv(myArray(j), vbUnicode)) > 0 Then tmp = myArray(i) myArray(i) = myArray(j) myArray(j) = tmp End If Next j Next i End Sub Sub フォルダ指定() Dim rc As Long With Application.filedialog(msoFileDialogFolderPicker) .AllowMultiSelect = False rc = .Show If rc = -1 Then myfolder = .SelectedItems.Item(1) ChDrive Left(myfolder, 1) ChDir myfolder End If End With Debug.Print myfolder End Sub Sub サブフォルダ一覧取得() Dim myfso, buf As Variant Set myfso = CreateObject("scripting.filesystemobject") Set buf = CreateObject("scripting.filesystemobject") Dim i As Integer i = 1 With myfso.getfolder(myfolder) For Each buf In .subfolders ReDim Preserve mySubfld(i) mySubfld(i) = buf.Name i = i + 1 Next End With Debug.Print VarType(mySubfld) If SafeArrayGetDim(mySubfld) <> 0 Then Call バブルソート_API(mySubfld) End If End Sub Sub フォルダ内ファイル取得(n) Dim tmpfile As Variant Dim i As Integer ChDir myfolder & "¥" & mySubfld(n) tmpfile = Dir("*.jpg") i = 1 Do While tmpfile <> "" ReDim Preserve myfname(i) myfname(i) = tmpfile tmpfile = Dir() i = i + 1 Loop If SafeArrayGetDim(myfname) <> 0 Then Call バブルソート_API(myfname) End If End Sub Sub 画像貼り付け表作成() Dim s, t As Integer For t = 1 To UBound(mySubfld) + 1 '----------列名箇所のセル枠の作成---------- Cells(1, t).Select Selection.ColumnWidth = セル列の幅 Selection.RowHeight = 13 With Selection .WrapText = False .Orientation = 0 .AddIndent = False .ShrinkToFit = False .MergeCells = False .Font.Size = 表のフォント .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter End With Selection.Merge Selection.Borders(xlEdgeTop).LineStyle = xlContinuous Selection.Borders(xlEdgeBottom).LineStyle = xlContinuous Selection.Borders(xlEdgeLeft).LineStyle = xlContinuous Selection.Borders(xlEdgeRight).LineStyle = xlContinuous '----------行名箇所のセル枠の作成---------- For s = 1 To myfileNmax + 1 + 1 Step 1 If t = 1 Then Range(Cells(s, 1), Cells(s, 1)).Select Selection.ColumnWidth = 3 Selection.RowHeight = セル行の高さ With Selection .WrapText = False .AddIndent = False .ShrinkToFit = False .MergeCells = False .Orientation = 90 .Font.Size = 表のフォント .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter End With Selection.Merge Selection.Borders(xlEdgeTop).LineStyle = xlContinuous Selection.Borders(xlEdgeBottom).LineStyle = xlContinuous Selection.Borders(xlEdgeLeft).LineStyle = xlContinuous Selection.Borders(xlEdgeRight).LineStyle = xlContinuous End If '----------画像貼り付け箇所に罫線を引く---------- Cells(s, t).Select With Selection.Borders(xlEdgeRight) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeBottom) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With Next s Next t End Sub Sub 画像貼り付け(ByRef j As Integer) Dim i As Integer Dim objshape As Shape Dim myCell As Range Dim tmp As Object For i = 2 To UBound(myfname) + 1 Set myCell = Cells(i, j) myCell.Select Set objshape = ActiveSheet.Shapes.AddPicture( _ Filename:=myfname(i - 1), _ linktofile:=False, _ savewithdocument:=True, _ Left:=Selection.Left, _ Top:=Selection.Top, _ Width:=0, _ Height:=0) '画像サイズと貼り付け位置の調整 With ActiveSheet.Shapes.Range(objshape.Name) .ScaleWidth 1, msoTrue .ScaleHeight 1, msoTrue .LockAspectRatio = False .Width = myCell.Width - 1 .Height = myCell.Height - 1 .Left = myCell.Left + (myCell.Width - .Width) / 2 .Top = myCell.Top + (myCell.Height - .Height) / 2 ' .Line.Weight = 0.5 End With Next i End Sub Sub 全画像クリア() Dim Shp As Object Dim r As Range Cells.Select For Each Shp In ActiveSheet.Shapes Set r = Range(Shp.TopLeftCell, Shp.BottomRightCell) If Not Intersect(r, Selection) Is Nothing Then Shp.Delete End If Next End Sub Sub 全セルクリア() Cells.Clear ' ActiveSheet.UsedRange.ClearContents ' ActiveSheet.UsedRange.ClearFormats End Sub
以上
<広告>
リンク