VBAでサブフォルダ内の写真サイズをチェックするツール

VBAで写真のピクセル（幅、高さ）サイズをチェックするツールを作成していますが

階層はサブフォルダの中にある写真まで抽出するものです。

下記の記述で行うと　duf に上手くディレクトリが格納されないのですが

どうしたらよいでしょうか？


Sub サブフォルダも取得()

Dim buf As Variant, i As Long, Dinm As String
Dim r As Long, s As Long, Sname As String
Dim pic As Variant, duf As Variant, Sdinm As String


'-----ファイルが入っているフォルダのデェレクトリを指定する-----’

With Application.FileDialog(msoFileDialogFolderPicker) 'FileDialogメソッドを使用してフォルダを指定する’
.Title = "ブックが保存されているフォルダを選択して下さい"
If .Show = False Then Exit Sub
Dinm = .SelectedItems(1)
End With

duf = Dir(Dinm, vbReadOnly)

Do While duf <> ""


'サブフォルダ内-------------------------

buf = Dir(Dinm & "\" & Sdinm & "\*.jpg")

Do While buf <> ""

Set pic = LoadPicture(Dinm & "\" & buf) 'LoadPicture関数を使用してbufのサイズを取得

pWidth = CLng(CDbl(pic.Width) * 24 / 635)

pheight = CLng(CDbl(pic.Height) * 24 / 635)


ThisWorkbook.Activate

Worksheets(1).Activate

r = Cells(Rows.Count, "B").End(xlUp).Row 'B列の最終行を取得’

s = r + 1 'B列の最終行の次の行’

Cells(s, 2) = pheight

Cells(s, 3) = pWidth

buf = Dir()

Loop

'サブフォルダ内-------------------------

duf = Dir()

Loop


End Sub

No.1 回答者： fujillin 回答日時： 2019/10/03 10:57

こんにちは

全部をちゃんと見ていませんが・・・

＞下記の記述で行うと　duf に上手くディレクトリが格納されない
直接の原因はパスの指定方法だと思われます。
変数Dinmはフォルダパスそのままなので、該当するものが自分自身以外にないため、戻り値が""になっていると考えられます。
フォルダ内のファイルに関して調べたけいのであれば、
　duf = Dir(Dinm & "\", vbReadOnly)
とかにしておかないと・・・

その他いろいろ
・If .Show = False Then Exit Sub～　は意図が不明
　というか一般的には戻り値を変数で受けて、With構文は使用しないのでは？
・質問文には「サブフォルダ」とあるが、Dirの第二引数でファイルを指定してる
・2重ループの制御変数に同じ変数を利用しているので、
　どう制御されるのかは神のみぞ知る
などなど。

最初の数行しか見ていないので、まだまだありそうですが、とりあえず気付いた点です。

この回答へのお礼

知っている知識だけでどうにかしようと考えましたがハードルがかなり高かったです。
勉強しなおします。回答ありがとうございました。

お礼日時：2019/10/03 12:52

No.2 回答者： めぐみん_ 回答日時： 2019/10/03 11:57

Dir関数が持てる条件は１つなので、ファイルを指定した段階で duf = Dir(Dinm, vbReadOnly) これは消えちゃうでしょう。

再帰的な処理だと主に FileSystemObject （FSO）を用いるとググるとありますよ。

サブフォルダを含めてファイル一覧を取得する（Dir関数の再帰呼び出し）
https://www.moug.net/tech/exvba/0060088.html

この回答へのお礼

知っている知識だけでどうにかしようと考えましたがハードルがかなり高かったです。
勉強しなおします。回答ありがとうございました。

お礼日時：2019/10/03 12:52

No.3 ベストアンサー 回答者： Qchan1962 回答日時： 2019/10/03 12:33

duf = Dir(Dinm, vbReadOnly)　は、duf =””ですよね。

変数エラーを回避して実行してもDo While duf <> ""で抜けてduf = Dir()で当然のこと
エラーが返ってきます。
やりたい事は、理解できますので、
実行できるものを作って良かったかは、不明ですが、、
以前作った再帰処理プロセスサンプルにご質問のコードを当てはめてサンプルを作ってみました。
一部、変数名などは変えてしまいましたが、読み解いてください。

r = Cells(Rows.Count, "B").End(xlUp).Row 'B列の最終行を取得’
s = r + 1 'B列の最終行の次の行’
Cells(s, 2) = pheight
Cells(s, 3) = pWidth
この辺は、少し変えましたが、基本同じです。また、再帰処理などで多くのデータを扱うなら
配列などに入れ一気に書き出すように変更された方が良いと思います。
A列にファイルpathと名前を出力していますが、必要なければコメントにしてください。


'Microsoft Scripting Runtime の事前バインドしてください。（参照設定をお願いします。）
Option Explicit
Private PATH_ As String 'ルートフォルダーのフルパス
Dim Pch_Arr() As Variant
Private Sub listSubFolders(ByVal folder_ As Scripting.Folder, ByRef n As Long)
Dim fol As Scripting.Folder
　　For Each fol In folder_.SubFolders
　　　ReDim Preserve Pch_Arr(n)
　　　Pch_Arr(n) = fol & "\"
　　　n = n + 1
　　　listSubFolders fol, n '再帰処理
　　Next
　　Set fol = Nothing
End Sub
Sub Recursive_Processing_sample()
'2011
Dim i As Long, j As Long, n As Long
Dim File_Name As String, Extension As String
Dim fso As Scripting.FileSystemObject
Dim r As Long, s As Long
Dim pic As Variant, pheight As Variant, pWidth As Variant
　　With Application
　　　.ScreenUpdating = False
　　　.EnableEvents = False
　　　.Calculation = xlCalculationManual
　　End With
　　Extension = ".jpg" '----拡張子設定
　　With Application.FileDialog(msoFileDialogFolderPicker)
　　　.InitialFileName = ThisWorkbook.Path
　　　If .Show = True Then
　　　PATH_ = .SelectedItems(1) & "\"
　　　End If
　　End With
　　ReDim Pch_Arr(0)
　　Pch_Arr(0) = PATH_
　　n = n + 1
　　Set fso = New FileSystemObject
　　On Error GoTo ErrHndl
　　listSubFolders fso.GetFolder(PATH_), n
　　If Sgn(Pch_Arr) <> 0 Then
　　　For j = 0 To UBound(Pch_Arr)
　　　　File_Name = Dir(Pch_Arr(j) & "*" & Extension, vbReadOnly)
　　On Error Resume Next
'---------＜主な処理
　　　　Do While File_Name <> ""
　　　　　　Set pic = LoadPicture(Pch_Arr(j) & "\" & File_Name) 'LoadPicture関数を使用してbufのサイズを取得
　　　　　　pWidth = CLng(CDbl(pic.Width) * 24 / 635)
　　　　　　pheight = CLng(CDbl(pic.Height) * 24 / 635)
　　　　　　With ThisWorkbook.Worksheets(1)
　　　　　　　r = .Cells(Rows.Count, "B").End(xlUp).Row + 1 'B列の最終行を取得’
　　　　　　　.Cells(r, 1) = Pch_Arr(j) & " 【 " & File_Name & " 】"
　　　　　　　.Cells(r, 2) = pheight
　　　　　　　.Cells(r, 3) = pWidth
　　　　　　End With
　　　　　　Set pic = Nothing
　　　　　　File_Name = Dir()
　　　　Loop
'---------＞主な処理
　　　Next j
　　End If
　　MsgBox ("処理終了")
ExitSub:
　　Set fso = Nothing
　　With Application
　　　.ScreenUpdating = True
　　　.EnableEvents = True
　　　.Calculation = xlCalculationAutomatic
　　End With
　　Exit Sub
ErrHndl:
　MsgBox Err.Description
　Err.Clear
　GoTo ExitSub
End Sub

この回答へのお礼

知っている知識だけでどうにかしようと考えましたがハードルがかなり高かったです。
勉強しなおします。回答ありがとうございました。

お礼日時：2019/10/03 12:53