フォルダ 指定フォルダの最下階層までフォルダやファイルを参照ZIP対象(NameSpace)

※より実装に近く表示させる為、コードの改行を避けています。スマホ等で閲覧される際は向きを変えてご覧ください。

※実装するバージョンによってはバージョンアップの仕様により動作しないコードもあります。実装には動作確認の上ご使用下さい。

Option Explicit

Dim FName() As String, FPath() As String, cntF As Long
Dim LName() As String, LPath() As String, LSize() As Double, cntL As Long

Sub FolderInFolderFileReference( _
  ByRef FNm() As String, ByRef FPt() As String, _
  ByRef LNm() As String, ByRef LPt() As String, ByRef LSz() As Double)
'****************************************************************
'指定フォルダの最下階層までフォルダやファイルを参照(NameSpace)
'****************************************************************
'F:Folder   を示します。
'L:File     を示します。
'ZIPファイル対象。

Dim objShlApp As Object
Dim objNmSpc As Object
Dim objFldItmS As Object
Dim n As Long

'再初期化と動的配列のメモリの解放
Erase FName
Erase FPath
Erase LName
Erase LPath
cntF = 0
cntL = 0

Set objShlApp = CreateObject("Shell.Application")
Set objNmSpc = objShlApp.NameSpace(ThisWorkbook.Path)
Set objFldItmS = objNmSpc.Items()

Call WorkToRecur(objFldItmS)

'コピー
FNm = FName: FPt = FPath
LNm = LName: LPt = LPath: LSz = LSize

Set objFldItmS = Nothing
Set objNmSpc = Nothing
Set objShlApp = Nothing
End Sub

Private Sub WorkToRecur(objTmpFldItmS)
'********************************
'再帰処理
'********************************
Dim objFldItm As Object
Dim objItm As Object
Dim n As Variant

    For n = 0 To objTmpFldItmS.Count - 1
        Set objItm = objTmpFldItmS.Item(n)

            If objItm.IsFolder Then
                'Case Folder
                ReDim Preserve FName(cntF) As String
                ReDim Preserve FPath(cntF) As String

                FName(cntF) = objItm.Name
                FPath(cntF) = objItm.Path

                cntF = cntF + 1

                Set objFldItm = objItm.GetFolder
                '再帰呼出
                Call WorkToRecur(objFldItm.Items())
            Else
                'Case File
                ReDim Preserve LName(cntL) As String
                ReDim Preserve LPath(cntL) As String
                ReDim Preserve LSize(cntL) As Double
                LName(cntL) = objItm.Name
                LPath(cntL) = objItm.Path
                LSize(cntL) = objItm.Size
                cntL = cntL + 1
            End If
    Next n

Set objItm = Nothing
Set objFldItm = Nothing

End Sub
Option Explicit

Private Sub Test()
Dim FNm() As String, FPt() As String
Dim LNm() As String, LPt() As String, LSz() As Double
Dim n As Long

Call FolderInFolderFileReference(FNm, FPt, LNm, LPt, LSz)

For n = LBound(FNm) To UBound(FNm)
    Debug.Print FNm(n) & vbTab & FPt(n)
Next n
MsgBox UBound(FNm) + 1

For n = LBound(LNm) To UBound(LNm)
    Debug.Print LNm(n) & vbTab & LSz(n)
Next n
MsgBox UBound(LNm) + 1
'0101.jpg    4956
'0102.jpg    4853
'0103.jpg    4383
'0104.jpg    4360
'0105.jpg    3961
End Sub

 

2000年01月01日|[VBサンプルコード]:[フォルダ]