| |
▼さくら さん：
>確認・検証後、また結果等書き込みに参ります。
ちょっと時間があったもので、
上のDir関数をつかったサブフォルダを含むファイル(*.xls)の検索スピードと
FileSystemObjectによる検索と
FindFile APIによる検索スピードを比較してみました。
以下が、あるフォルダを3つの方法で検索したときの処理時間です。
'方法 Hit数 所要時間（ミリ秒）
Dir ( 1113 ) 1497
Fso ( 1122 ) 10358
API ( 1122 ) 234
ということで、Fsoは論外、Dirはそこそこの時間ですが、ヒットした
ファイルの数が他の方法に比較して少ない（検索漏れがある？）、
やはり APIを使ったほうが 桁違いに時間が短縮されるし、
パスの長さの制限や、Unicodeで検索できるなど安心ですので、
以下に、FindFileW APIを使ったコードを紹介しておきますね
Dirの方法に比べ、コードは
先頭の宣言部にいろいろ宣言があり、とっつきにくいですが、
Sub FindFile() の中でやっていることは
前の Dirによる FileSearch() でやってることと「瓜二つ」
なので、読み比べてみてください。
なお、説明し忘れましたが、
検索フォルダの設定は どちらのマクロも 以下のところです。
> Dim LookIn As String: LookIn = "D:\(Data)\"
ここをそちらの環境に替えてお試しください。
'----------------------------------------------------------
Option Explicit
Private Const MAX_PATH = 260
Private Const INVALID_HANDLE = (-1)
' WIN32_FIND_DATA構造体
Private Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As Currency
ftLastAccessTime As Currency
ftLastWriteTime As Currency
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName(1 To MAX_PATH * 2) As Byte
cAlternate(1 To 14 * 2) As Byte
End Type
Private Declare Function FindFirstFile _
Lib "kernel32" Alias "FindFirstFileW" _
(ByVal lpFileName As Long, _
lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile _
Lib "kernel32" Alias "FindNextFileW" _
(ByVal hFindFile As Long, _
lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose _
Lib "kernel32" _
(ByVal hFindFile As Long) As Long
'----------------------------------------------------------
'処理時間計測用
Private Declare Function timeGetTime Lib "winmm.dll" () As Long
'for さくら
Sub さくら3_API()
Dim LookIn As String: LookIn = "D:\(Data)\"
Dim Filename As String: Filename = "*.xls"
Dim FoundFiles() As String
Dim nCount As Long
Dim mCount As Long
Dim t&
t& = timeGetTime()
'LookIn : 検索Rootフォルダ
'Filename : 検索ファイル名
'FoundFiles(): マッチしたファイル名の配列()
'nCount : ファイルの数
'mCount : RootおよびRoot直下のフォルダ数
FindFile LookIn, LCase$(Filename), FoundFiles(), nCount, mCount, 0
Debug.Print "'API("; nCount - mCount; ")", timeGetTime() - t
If (nCount - mCount) > 0 Then
Dim r As Range, c As Range
With Worksheets
With .Add(After:=.Item(.Count))
Set r = .[A1].Resize(nCount, 2)
r.Value = Trans(FoundFiles())
Application.ScreenUpdating = 0
On Error Resume Next
For Each c In r.Columns(2). _
Cells.SpecialCells(xlConstants).Areas
.Sort Key1:=c.Item(1), Header:=xlNo
Next
On Error GoTo 0
Application.ScreenUpdating = 1
End With
End With
MsgBox nCount - mCount & "個のファイルがマッチしました"
End If
End Sub
Private Sub FindFile(strDir As String, strFind As String, _
FoundFiles() As String, nCount As Long, _
mCount As Long, ByVal Level As Long)
Dim p As String
Dim fDATA As WIN32_FIND_DATA
Dim f As String
Dim hFile As Long
Dim strName As String
Dim i As Long
Dim SubDir() As String, nSub As Long
If Right$(strDir, 1) <> "\" Then strDir = strDir & "\"
p = strDir & "*.*" 'すべてのファイルを検索
hFile = FindFirstFile(StrPtr(p), fDATA)
If hFile = INVALID_HANDLE Then Exit Sub
If Level <= 1 Then
nCount = nCount + 1
mCount = mCount + 1
ReDim Preserve FoundFiles(1, 1 To nCount)
FoundFiles(0, nCount) = strDir '現在フォルダ名出力
End If
Do
f = fDATA.cFileName
f = Left$(f, InStr(f, vbNullChar) - 1)
If fDATA.dwFileAttributes And vbDirectory Then
If Left$(f, 1) <> "." Then
' サブフォルダならば 配列SubDir() に一時記憶
nSub = nSub + 1
ReDim Preserve SubDir(1 To nSub)
SubDir(nSub) = strDir & f
End If
Else
strName = LCase$(f)
If strName Like strFind Then
' 検索ファイル名にマッチしたファイルの出力
nCount = nCount + 1
ReDim Preserve FoundFiles(1, 1 To nCount)
FoundFiles(1, nCount) = strName
End If
End If
Loop While FindNextFile(hFile, fDATA)
FindClose hFile
'------------
'サブフォルダ内の検索
If nSub Then
For i = 1 To nSub
FindFile SubDir(i), strFind, FoundFiles(), nCount, mCount, Level
Next
End If
End Sub
Private Function Trans(ff() As String) As String()
Dim sv() As String
Dim i As Long, n As Long
n = UBound(ff, 2)
ReDim sv(1 To n, 1)
For i = 1 To n
sv(i, 0) = ff(0, i)
sv(i, 1) = ff(1, i)
Next
Trans = sv()
End Function
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
