'呼び出しフォルダー

Private Sub CommandButton1_Click() 

    With Application.FileDialog(msoFileDialogFolderPicker)

        If .Show = True Then

            Cells(cnsRow, cnsCol) = .SelectedItems(1)

        End If

    End With

End Sub

Private Sub CommandButton2_Click()

    Call ファイル一覧取得完成

End Sub

Public Const cnsRow As Long = 4 '開始行

Public Const cnsCol As Long = 2 '開始列

Public ColMax As Long         '最終列

 

Sub ファイル一覧取得完成()

    Dim objFSO As FileSystemObject

    Dim strDir As String

    Dim i As Long, j As Long

  

    strDir = Cells(cnsRow, cnsCol)

    'FileSystemObjectのインスタンスの生成

    Set objFSO = New FileSystemObject

    'フォルダの存在確認

    If Not objFSO.FolderExists(strDir) Then

        MsgBox ("指定のフォルダは存在しません")

        Exit Sub

    End If

    '画面描画を停止

    Application.ScreenUpdating = False

    '表示領域を初期設定

    Range(Rows(cnsRow), Rows(Cells.SpecialCells(xlCellTypeLastCell).Row)).Clear

    Cells(cnsRow, cnsCol) = strDir

    '開始行列

    i = cnsRow + 1

    j = cnsCol

    ColMax = cnsCol

    '再帰処理モジュールのコール

    Call GetDirFiles(objFSO.GetFolder(strDir), i, j)

    'オブジェクトの解放

    Set objFSO = Nothing

    '列幅を調整

    Range(Columns(cnsCol), Columns(Columns.Count)).ColumnWidth = 3

    Range(Columns(ColMax), Columns(ColMax + 2)).EntireColumn.AutoFit

    'サイズ、更新日時の罫線設定

    Call SetLine2(Range(Cells(cnsRow, ColMax + 1), Cells(i - 1, ColMax + 2)))

    '見出し行の外枠罫線

    Call SetLine3(Range(Cells(cnsRow, cnsCol), Cells(cnsRow, ColMax + 2)))

    '一覧部分の外枠罫線

    Call SetLine3(Range(Cells(cnsRow + 1, cnsCol), Cells(i - 1, ColMax + 2)))

    '見出しの書式設定

    Cells(cnsRow, ColMax).Font.Bold = True

    With Cells(cnsRow, ColMax + 1)

        .Value = "サイズ"

        .HorizontalAlignment = xlRight

    End With

    With Cells(cnsRow, ColMax + 2)

        .Value = "更新日時"

        .HorizontalAlignment = xlRight

    End With

    '指定フォルダに移動しておく

    Cells(cnsRow, cnsCol).Select

    'ステータスバーを消して、描画再開

    Application.StatusBar = False

    Application.ScreenUpdating = True

End Sub

 

Sub GetDirFiles(ByVal objFolder As Folder, ByRef i As Long, ByRef j As Long)

    Dim objFolderSub As Folder

    Dim objFile As File

    Dim strSplit() As String

    'ステータスバーに処理中のフォルダを表示

    Application.StatusBar = objFolder.Path

    '最終列が増えた場合は、サイズの前に1列追加する

    If j > ColMax Then

        Columns(j).Insert Shift:=xlToRight

        ColMax = j

    End If

    'サブフォルダの取得

    For Each objFolderSub In objFolder.SubFolders

        Cells(i, j) = objFolderSub.Name

        'フォルダにハイパーリンクを設定する場合

         'ActiveSheet.Hyperlinks.Add _

　　　　'　　　　　　Anchor:=Cells(i, j), _

　　　　'　　　　　　Address:=objFolderSub.Path, _

　　　　'　　　　　　TextToDisplay:=objFolderSub.Name

        Call SetLine1(i, j)

        i = i + 1

        Call GetDirFiles(objFolderSub, i, j + 1)

    Next

    'ファイルの取得

    For Each objFile In objFolder.Files

        With objFile

            Cells(i, j) = .Name

            strSplit = Split(objFile.Path, ".")

            If UBound(strSplit) > 0 Then

                Select Case LCase(strSplit(UBound(strSplit)))

                    Case "xls", "xlsx"

                        ActiveSheet.Hyperlinks.Add _

                                    Anchor:=Cells(i, j), _

                                    Address:=.Path, _

                                    TextToDisplay:=.Name

                End Select

            End If

            Cells(i, ColMax + 1) = WorksheetFunction.RoundUp(.Size / 1024, 0)

            Cells(i, ColMax + 1).NumberFormatLocal = "#,##0 ""KB"""

            Cells(i, ColMax + 2) = .DateLastModified

            Cells(i, ColMax + 2).NumberFormatLocal = "yyyy/mm/dd hh:mm:ss"

'            Cells(i, ColMax + 3).BuiltinDocumentProperties (3) 'Author

'            Cells(i, ColMax + 4).BuiltinDocumentProperties (7) 'Last Author

'            Cells(i, 4).Value = obj.BuiltinDocumentProperties(3) 'Author

'            Cells(i, 5).Value = obj.BuiltinDocumentProperties(7) 'Last Author

 

            Call SetLine1(i, j)

            i = i + 1

        End With

    Next

    'オブジェクトの解放

    Set objFolderSub = Nothing

    Set objFile = Nothing

End Sub

 

'フォルダ名、ファイル名の行の罫線

Sub SetLine1(ByVal i As Long, ByVal j As Long)

    If j > cnsCol Then

        With Range(Cells(i, cnsCol), Cells(i, j - 1))

            .Borders(xlEdgeLeft).LineStyle = xlContinuous

            .Borders(xlInsideVertical).LineStyle = xlContinuous

        End With

    End If

    With Range(Cells(i, j), Cells(i, ColMax + 2))

        .Borders(xlEdgeLeft).LineStyle = xlContinuous

        .Borders(xlEdgeTop).LineStyle = xlContinuous

    End With

End Sub

 

'サイズ、更新日時の罫線設定

Sub SetLine2(ByRef myRange As Range)

    With myRange.Borders(xlEdgeLeft)

        .LineStyle = xlContinuous

        .Weight = xlHairline

    End With

    With myRange.Borders(xlInsideVertical)

        .LineStyle = xlContinuous

        .Weight = xlHairline

    End With

End Sub

 

'外枠罫線、少し太く

Sub SetLine3(ByRef myRange As Range)

    With myRange.Borders(xlEdgeLeft)

        .LineStyle = xlContinuous

        .Weight = xlMedium

    End With

    With myRange.Borders(xlEdgeTop)

        .LineStyle = xlContinuous

        .Weight = xlMedium

    End With

    With myRange.Borders(xlEdgeBottom)

        .LineStyle = xlContinuous

        .Weight = xlMedium

    End With

    With myRange.Borders(xlEdgeRight)

        .LineStyle = xlContinuous

        .Weight = xlMedium

    End With

End Sub