【VBA_再帰】複数フォルダ内を検索拡張子を決めて画像を取り出す

お知らせ記事には広告が含まれておりますがExcelのスキルUPに繋がる様コンテンツ自体は手を抜かずに作成しております

再帰呼び出しを使ってフォルダ内から画像を抽出

階層の異なるフォルダ群を検索し特定の拡張子を持った画像データを取り出すというコードを紹介します。

再帰を使う事でフォルダ群の隅々まで画像を検索する事ができます。

EnjoyExcel
EnjoyExcel

階層が異なるフォルダ群を確認しつつ周回するのは手間がかかるしコードも長くなります。

再帰呼び出し(処理)を使うと効率良く立ち回ることができますよ。

1つ前の記事で再帰の基本構造を解説しました。次は応用編です。

再帰自体の勉強ができる事に加え複数のプロシージャを組み合わせて使うサブルーチンも勉強できます。

理屈や動きは分かったけど実務でどう使うのか・・・という問い合わせをいただきます。

この問い合わせに対して回答を用意しました。より具体的な事例で再帰を使ってみる事にします。

関連記事

前回記事です。再帰呼び出しについて画像と動画で解説しています。

再帰呼び出しが苦手だったりよく分からない方でも理解できる内容になっています。

再帰を勉強している方ならおそらくクラスも理解できます。興味がある方は以下記事をご覧ください。

クラスモジュールを解説VBA|クラスとは何か|本当に難しいのかを3つのポイントから検証

アウトプット

早速アウトプットを紹介しつつ解説していきます。

繰り返しとなりますが「フォルダ群を周回し拡張子を指定して画像データを取り出す」というコードです。

環境、ワークシート、コードの順に紹介します。その後解説という流れで進めていきます。

環境

自PCのデスクトップにtopというフォルダを用意しました。

さらに配下にフォルダと画像を用意しました。サンプルとしては少ないですが説明には十分です。

最終的に画像のような環境を用意しています。階層はバラバラ、画像の拡張子も複数という状態です。

3A-1に.jpgが1つ、1B-1に.jpegが3つ、2C-1に.pngが1つ、2C-2に.jpgが1つです。

ワークシート

画像を抽出するためのワークシートはこのように作成しました。

画像とリストを用意しましたので①~⑤の番号に合わせて内容を確認してください。

ワークシートの解説です。画像内の①~⑤に対する説明を用意しました。

以下のような仕様でデータを用意しました。

番号要素説明
パス調査対象のフォルダのパスを入力
拡張子抽出する画像の拡張子を選択 データの入力規則→リストで作成
実行ボタンボタンを押下するとコードが実行される
画像抽出位置セルA8を起点としてA列に抽出した画像、B列に画像名が並ぶ
削除ボタンA列に配置された画像、B列に表示された画像名を削除する
②で用意したリストボックスはエクセルのアイコンに用意されている「データの入力規則」で作成しています。

パスでフォルダを指定後リストで拡張子を決めれば配下の画像を全て持ってくるという仕様です。

コード

コードは3ブロックに分けて用意しています。全て必要です。(プロシージャは全部で5つです)

5つのプロシージャを組み合わせて作業を進めていきます。まずはmainプロシージャです。

ワークシートの実行ボタンに連動しているのはこのプロシージャになる様に準備をしてください。

Sub main()

'********************************************
Dim cnt As Long 'セルの行数
Dim r As Long '行の取得
Dim path As String 'パスを格納する変数
path = Range("H3").Value 'パスの初期値
cnt = 8 'セルの行数の初期値
'********************************************

Application.ScreenUpdating = False

'画像が居る行の最終行を取得する為のプロシージャへ飛ぶ
Call rowsCount(r)

'ここで8行目以降の画像を確認しcntの値を決める
If r >= cnt Then
    cnt = r + 1
End If

'画像を検索する為のプロシージャへ飛ぶ
Call serchPicture(path, cnt)

Application.ScreenUpdating = True
    
End Sub

続いて3つのプロシージャを用意しました。

Functionプロシージャではないのですが3つのプロシージャは関数の様に使うイメージで用意しました。

  • フォルダを周回する為のプロシージャ(自分自身を呼び出す再帰呼び出しを含む)
  • 画像を取得しセルに出力する為のプロシージャ(別記事からのコードを転用)
  • ワークシートA列の最終行を把握する為のプロシージャ

1点ポイントです。この作業を忘れない様にしてください。

ここがポイント

VBEのツールタブ参照設定Microsoft Scripting Runtime に必ずチェックを入れてください。

'++++++++++++++++++++++++++++++++++++++++++++
Sub serchPicture(ByRef path As String, ByRef ct As Long)

'********************************************
Dim buf As String 'ファイル名を格納する為の変数
Dim flr As Object 'フォルダを格納する為の変数
Dim rng As Range '画像を貼るセルを格納する為の変数
Dim fso As Scripting.FileSystemObject 'ファイルシステムオブジェクトを格納する為の変数
Set fso = New Scripting.FileSystemObject  '変数にファイルシステムオブジェクトを格納する
'********************************************

'引数にあうファイルがあった時は変数bufに値を格納
buf = Dir(path & "\*." & Range("H5"))

'変数bufに値があるときはループに入る
'bufに値が入らなければループが終わる様になっている
Do While buf <> ""
    '指定した拡張子だったら対象のセルを決めてgetPictureへ飛ぶ
    If UCase(buf) Like "*." & UCase(Range("H5").Value) Then
        Set rng = Cells(ct, 1)
        Call getPicture(path, buf, rng)
        '戻ってきたら変数ctを1つ送る (次の行が選択されるように準備)
        ct = ct + 1
        '対象フォルダ内にある別のファイルを選択
    End If
        buf = Dir()
Loop

'指定のパス内にあるフォルダをループする
For Each flr In fso.getfolder(path).SubFolders
    '変数flrで確保されたフォルダのパス等を持って再帰に入る
    Call serchPicture(flr.path, ct)
Next

End Sub
'++++++++++++++++++++++++++++++++++++++++++++
'++++++++++++++++++++++++++++++++++++++++++++
Sub getPicture(ByVal path As String, ByVal buf As String, ByVal rng As Range)

'このプロシージャは自身の記事内のコードを転用しているので説明省略

With rng.Worksheet.Shapes.AddPicture _
    (Filename:=path & "\" & buf, _
    LinkToFile:=False, _
    SaveWithDocument:=True, _
    Left:=rng.Left, _
    Top:=rng.Top, _
    Width:=0, _
    Height:=0)
                                                       
    .LockAspectRatio = True
    .Placement = xlMoveAndSize
    
    .ScaleHeight 1, msoTrue
    .ScaleWidth 1, msoTrue
    
    If .Width > rng.Width - 2 Then
        .Width = rng.Width - 2
    End If

    If .Height > rng.Height - 2 Then
        .Height = rng.Height - 2
    End If

    .Top = .Top + ((rng.Height - .Height) / 2)
    .Left = .Left + ((rng.Width - .Width) / 2)
    rng.Offset(0, 1) = buf
End With

End Sub
'++++++++++++++++++++++++++++++++++++++++++++
'++++++++++++++++++++++++++++++++++++++++++++
Sub rowsCount(ByRef rw As Long)

'********************************************
Dim shp As Shape  '画像などの図形全般を格納する変数
'********************************************

'画像、図形の最終行を求める
For Each shp In ActiveSheet.Shapes
    '入力規則のリストがShape扱いになるので除外する為のループ
    If Not shp.Name Like "Drop Down *" Then
        '結果としてドロップダウンリスト以外のShapeがいる行番号が取得される
        rw = Application.Max(rw, shp.BottomRightCell.Row)
    End If
Next

End Sub
'++++++++++++++++++++++++++++++++++++++++++++

最後は削除ボタンのコードです。画像と画像名を削除する為のプロシージャです。

Sub clearPicture()

'********************************************
Dim myRng As Range  '画像を消す範囲を指定
Set myRng = Range("A:A")  '変数myRngはオブジェクトなのでSetが必要
Dim sp As Variant  '画像を取得する為の変数
Dim r As Long
'********************************************

Application.ScreenUpdating = False

'アクティブシート内のシェイプ(画像)を順番にループしていく
For Each sp In ActiveSheet.Shapes
'入力規則のリストがShape扱いになるので除外する為のループ
  If Not sp.Name Like "Drop Down *" Then
  'Intersectメソッドで変数myRangeと順番に選択したシェイプが重なっているか確認
    If Not Intersect(Range(sp.TopLeftCell, sp.BottomRightCell), myRng) Is Nothing Then
      'A列にかかっている画像は消す
      sp.Delete
    End If
  End If
Next
    
'変数myRngの開放
Set myRng = Nothing

'B列の最終行を取得
r = Cells(Rows.Count, 2).End(xlUp).Row
'B列の情報を削除
If r > 7 Then
  Range(Cells(8, 2), Cells(r, 2)).ClearContents
End If
    
Application.ScreenUpdating = True

End Sub

これで準備はOKです。

コード実行後の様子

指定されたパスと拡張子の情報を使って画像を抽出できました。

A列には画像が用意されB列には画像名を表示させています。

このあと拡張子を変えて実行ボタンを押すと現在表示されている画像の下に新たに画像が並びます。

削除ボタンを押すとA列の画像とB列の画像名が削除されます。

解説

5つのプロシージャ毎にポイントを絞って解説します。

作業をイメージしやすい様にどうやってフォルダを周回しているのかを線で示しておきました。

以下画像内の薄紫色の矢印の順番でフォルダを周回しています。

上の階層に戻ってきたり横の階層に移るために再帰処理が活躍しています。

main

このプロシージャが実行ボタンに連動しています。やっている事は2つです。

  • 画像を検索した後に貼付けを開始する行を決める(rowsCountプロシージャ)
  • 変数を抱えてserchPictureに飛ぶ(serchPictureプロシージャ)

rowsCountプロシージャで取得した値と変数cntの初期値を比較して画像の開始位置を決めています。

serchPictureプロシージャには以降の処理を全て担当してもらいます。

serchPicture

変数path内に指定した拡張子の画像の有無を確認します。

Dir関数についての解説は以下記事をご覧ください。動画も用意してあり分かり易く解説しています。

Dir関数について解説VBA|Dir関数を使ってフォルダ内の複数ファイルを順番に処理する

該当のデータが存在する時

変数bufに値が格納されます。その後変数bufに値があればDo Whileステートメントに入ります。

拡張子が大文字の場合は補正します。該当の画像だと判断されればgetPictureプロシージャへ飛びます。

getPictureプロシージャから戻ってきたら変数ctを1つ増やしてから次のデータを取りに行きます。

変数bufに値が入るうちはループを継続する事になります。

該当データが存在しない時

変数bufに値が入らない時はFor Eachステートメントに移動します。

検索中のフォルダに別のフォルダ(サブフォルダ)があれば再帰呼び出しとなります。

変数flrに格納されているフォルダパスを持ってserchPictureプロシージャを呼び出します

getPicture

この中の処理はこちらの記事で使ったコードを転用しています。

このコードへ「B列に画像名を並べるという」作業を追加しています。

このコードのポイントは作業が速いこととセルの幅を変えるだけで画像の大きさを調整できる事です。

コードをメンテしなくてもセルの大きさを変えるだけで貼り付ける画像の大きさを調整できます。

rowsCount

mainプロシージャに連動しているプロシージャです。

実行ボタンを押す時にワークシートのどの行から画像を並べれば良いのかを確認しています。

このコードによってワークシートに既に画像が配置されている時はその後から画像を並べることができます。

ワークシート内のShapeオブジェクトを周回し各画像が居る右下のセル位置を変数rwに格納します。

Shapeオブジェクトは上から探していくのでループが終わった時は一番下の画像位置が取得出来ています。

その値をmainプロシージャに返すという仕事をしています。

入力規則のリストもShapeオブジェクト

セルH5に採用されているリストもFor Eachステートメントの対象になります

よってShepeオブジェクトの名前に”Drop Down*”が含まれているオブジェクトは対象外としています。

実行、削除ボタンもShapeオブジェクトですが実行には影響が無いのであえて回避していません。

clearPicture

このプロシージャが削除ボタンに連動しています。やっている事は2つです。

  • ワークシートA列の画像の削除
  • ワークシートB列の画像名の削除

画像の削除についてはこちらの記事でも使用しています。

キーになるコード

serchPictureプロシージャ全般です。再帰呼び出し(処理)の3要件が詰まっています。

  • 終了条件を決める ・・・ 検索対象フォルダが無くなるまで
  • 自己呼び出しを行う ・・・ 他にフォルダがある時はSerchPictureを呼び出す
  • 結果を結合する ・・・ ワークシートに画像を順番に貼り付ける

まとめ

再帰呼び出し(再帰処理)を実務に盛り込んでみました。

こうやって事例に当てはめると使い道がイメージできますね。

再帰を使えば「フォルダを周回してファイル名の一覧を作る」等他にも出来る事が沢山あります。

皆様の仕事にも再帰呼び出しが使える事例があります。機会があったらコードを書いてみてください。

EnjoyExcel

タイトルとURLをコピーしました