EXCEL/File - a羅針盤

１．フォルダの選択 †

フォルダ選択ダイアログを表示し選択したフォルダ名をFullPathで戻します。フォルダが選択されたかどうかの判定は、値がNothingかどうかで判断します。

Function Folder_Selection() As String
   Dim shl As Shell32.Shell
   Dim fldr As Shell32.folder
   
   Set shl = CreateObject("Shell.application")
   Set fldr = shl.BrowseForFolder(0, "フォルダを指定してください", 0)
   
   If fldr Is Nothing Then
      'NOP
   Else
      Folder_Selection = fldr.items.Item.Path
   End If
   
   Set shl = Nothing
   Set fldr = Nothing

End Function

↑

２．フォルダ内のファイルリストの取得 †

ファイル一覧を取得するだけであれば、VBAのDIR関数で十分ですが、ここではファイルを更新時間でソートしたいためとファイルの読取りの例として、OSのDIRコマンドの実行結果をTemporaryファイルに書き出し、その内容を読取ってフォルダ内のファイル一覧取得します。ファイル一覧をFullPathで取得し、ArrayListで戻します。
ここで使用したDIRのオプションを以下に示します。その他のオプションについてはウィンドウズのコマンドプロンプトでHELP DIRとタイプしてエンターして表示してください。

オプション	説明
B	ファイル名のみを表示します (見出しや要約が付きません)。
S	指定されたディレクトリおよびそのサブディレクトリのファイルを表示します。またファイル名をFullPathで表示します。
A	指定された属性のファイルを表示します。-D:ディレクトリを除く
O	ファイルを並べ替えて表示します。D:日時順
T	どのタイムフィールドで並べ替えるかを指定します。W: 最終更新

Function File_Search(foldr As String) As ArrayList
    Dim shl         As Object
    Dim fileName    As String
    Dim cmd         As String
    Dim tmp         As String
    Dim InputFNo    As Long
    Dim files       As Variant
    Dim i           As Integer
    Dim fileList    As New ArrayList

    On Error GoTo Err_Handler
   
    Set File_Search = fileList
    Set shl = CreateObject("WScript.Shell")
    fileName = Application.DefaultFilePath & "\TEMP" & CLng(Date) & ".txt"
    tmp = "DIR """ & foldr & """ /B/S/A:-D/O:D/T:W"
   
    cmd = "%ComSpec% /c " & tmp & " >""" & fileName & """"
    shl.Run cmd, 0, True
    
    InputFNo = FreeFile          '←Openするファイルの番号をFreeFile関数で決めます。
    Open fileName For Input As #InputFNo
         'ここではファイル番号をInputFNoとして、ファイルをバイナリの読取りとしてOpenします。
    files = Split(StrConv(InputB(LOF(InputFNo), #InputFNo), vbUnicode), vbCrLf)
         'InputB関数でファイル番号InputFNoのファイルをバイナリで読取ります。
         'InputBの第一パラメータは読込むバイト数です。
         'LOF関数はファイルの長さを返します。
    Close #InputFNo      '←ファイル番号InputFNoのファイルをCloseします。
    
    If 0 < UBound(files) Then
        For i = 0 To UBound(files) - 1
            fileList.Add CStr(files(i))
        Next i
    End If
    
    On Error Resume Next
    Kill fileName
    On Error GoTo 0
    Set shl = Nothing
   
    Exit Function
    
Err_Handler:
    MsgBox "Error: " & Err.Number & " : " & Err.Description
    On Error Resume Next
    Kill fileName
    On Error GoTo 0
End Function

↑

３．上記プロシージャを使用した例 †

Sub example1200()
    Dim foldr       As String
    Dim fileList    As ArrayList
    Dim i           As Long

    foldr = Folder_Selection
    If foldr = "" Then
        End
    End If

    Set fileList = File_Search(foldr)

    If fileList.Count > 0 Then
        For i = 0 To fileList.Count - 1
            Application.StatusBar = fileList(i)
            subProcedure fileList(i)     '←ファイル毎の処理をします。
        Next i
    Else
        MsgBox "No files are found."
    End If

    Set fileList = Nothing
    Application.StatusBar = False
                          
End Sub

Sub subProcedure(filename as String)
    MsgBox filename
End Sub

編集中

EXCEL Top

Last-modified: 2014-03-11 (火) 01:58:42 (3700d)