'ファイルタイム
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Private Type WIN32_FIND_DATA
dwFileAttributes As Long 'ファイル属性
ftCreationTime As FILETIME '作成日
ftLastAccessTime As FILETIME 'アクセス日
ftLastWriteTime As FILETIME '更新日
nFileSizeHigh As Long 'ファイルサイズ(Byte)
nFileSizeLow As Long 'ファイルサイズ(Byte)
dwReserved0 As Long '未使用
dwReserved1 As Long '未使用
cFileName As String * 260 'ファイル名
cAlternate As String * 14 'ファイル名フォーマット名
End Type
'ファイルの検索を開始する
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
'ファイルの検索を続行する
Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
'検索ハンドルを閉じる
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
Private Const INVALID_HANDLE_VALUE = -1
Private Type DIR_FILE_LIST
FileName As String
IsDirectory As Boolean
End Type
'-----------------------------------------------------------------------
' 関数名 : GetTargetFiles
' 機能 : ディレクトリ以下の指定拡張子のファイルを取得する
' 引数 : (in/out) Files … 取得したファイルを格納する配列
' (in)DirName … 検索元ディレクトリ
' (in)Extension … 拡張子
' 返り値 : True:検索元ディレクトリは存在する False:存在しない
'-----------------------------------------------------------------------
Public Function GetTargetFiles(ByRef Files() As String, ByVal DirName As String, _
ByVal Extension As String) As Boolean
Dim udtWin32 As WIN32_FIND_DATA
Dim hFile As Long
Dim ArrayIndex As Long
Dim FileListNum As Long
Dim i As Long
Dim UdtDFL() As DIR_FILE_LIST
'最後尾に \ が付いている場合は取る
If Right$(DirName, 1) = "\" Then DirName = Left$(DirName, Len(DirName) - 1)
'検索開始
hFile = FindFirstFile(DirName, udtWin32)
'ファイル・ディレクトリが存在しない場合は終了
If hFile = INVALID_HANDLE_VALUE Then Exit Function
Call FindClose(hFile)
'ディレクトリ以下のファイル・ディレクトリを取得する
FileListNum = GetFileList(UdtDFL, DirName)
If FileListNum = (-1) Then Exit Function
For i = 0 To FileListNum
'ディレクトリである
If UdtDFL(i).IsDirectory Then
Call GetTargetFiles(Files, DirName & "\" & UdtDFL(i).FileName, Extension)
'ファイルである
Else
'ファイルの拡張子が指定拡張子と等しい
If UCase$(Right$(UdtDFL(i).FileName, Len(Extension))) = UCase$(Extension) Then
'初回実行時 Files は配列無しなのでUBound()でエラーとなる
'それを回避するための強制エラー無視ロジック
On Error Resume Next
ArrayIndex = UBound(Files) + 1
On Error GoTo 0
'メモリー確保
ReDim Preserve Files(ArrayIndex) As String
'フルパスでファイル名を格納
Files(ArrayIndex) = DirName & "\" & UdtDFL(i).FileName
End If
End If
Next i
GetTargetFiles = True
End Function
'-----------------------------------------------------------------------
' 関数名 : GetFileList
' 機能 : ディレクトリのファイルを取得する
' 引数 : (in/out) UdtDFL … DIR_FILE_LIST構造体の配列
' (in)DirName … 検索元ディレクトリ
' 返り値 : UdtDFL配列数 ファイルが存在しない場合:-1
'-----------------------------------------------------------------------
Public Function GetFileList(ByRef UdtDFL() As DIR_FILE_LIST, _
ByVal DirName As String) As Long
Dim udtWin32 As WIN32_FIND_DATA
Dim hFile As Long
Dim ArrayIndex As Long
Dim Win32FileName As String
ArrayIndex = (-1)
'検索開始
hFile = FindFirstFile(DirName & "\*", udtWin32)
Do
'時々、再描画してあげましょう
If ArrayIndex Mod 10 = 0 Then DoEvents
'ファイル名取得
Win32FileName = Left$(udtWin32.cFileName, _
InStr(udtWin32.cFileName, Chr$(0)) - 1)
'親ディレクトリ、カレントディレクトリでない
If Left$(Win32FileName, 1) <> "." Then
ArrayIndex = ArrayIndex + 1
ReDim Preserve UdtDFL(ArrayIndex) As DIR_FILE_LIST
'ファイル名、ファイル属性を取得
With UdtDFL(ArrayIndex)
.FileName = Win32FileName
.IsDirectory = CBool(udtWin32.dwFileAttributes And vbDirectory)
End With
End If
Loop While FindNextFile(hFile, udtWin32) <> 0
Call FindClose(hFile)
GetFileList = ArrayIndex
End Function
以下は実行ロジック。しかも検索時間表示付き!!
Private Declare Function GetTickCount Lib "kernel32" () As Long
Private Sub Command1_Click()
Dim FileList() As String
Dim i As Long
Dim StartTime As Long
Dim EndTime As Long
'開始時間を取得
StartTime = GetTickCount
If GetTargetFiles(FileList, "C:\Program Files", "txt") Then
'終了時間を取得
EndTime = GetTickCount
For i = 0 To UBound(FileList)
Debug.Print FileList(i)
Next i
Debug.Print CStr(i) & "個のファイルが見つかりました(検索時間:" & _
Format$((EndTime - StartTime) / 1000, "0.00") & "秒)"
End If
End Sub
|