1.フォルダの選択 †フォルダ選択ダイアログを表示し選択したフォルダ名を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 2.フォルダ内のファイルリストの取得 †ファイル一覧を取得するだけであれば、VBAのDIR関数で十分ですが、ここではファイルを更新時間でソートしたいためとファイルの読取りの例として、OSのDIRコマンドの実行結果をTemporaryファイルに書き出し、その内容を読取ってフォルダ内のファイル一覧取得します。ファイル一覧をFullPathで取得し、ArrayListで戻します。
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 3.上記プロシージャを使用した例 †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 編集中 Last-modified: 2014-03-11 (火) 01:58:42 (3921d)
|