| |
▼ON さん:
>Application.FileSearch
>でのフォルダ、ファイルの検索が遅いので
それに、最新版Excel2007では、いまのところ使えないですしね(-_-)
>ファイルサーバーの所定のフォルダ配下には
以下のサンプルの
> Sub Try_FindFile()
内の
> myPath = "D:\(Data)"
> strFind = "abc.*"
を､
ファイルサーバーへのパスと 検索したいファイル名に置き換えて
お試しください｡
P.S. 前日投稿した Sub Try_Start()の検索法は
無駄があったので、削除しました。（もし前回投稿したものと
スピードを比較されたいのでしたら、2つのモジュールは別Bookにて
検証願います）
> Sub Try_FindFile()
では、2Stepで、
(1) 最初に指定フォルダのファイルを検索し、
(2) つぎに、サブフォルダの検索を行い、各SubFolder内を再帰呼び出しし、
同名のファイルを検索しています。
'-------------------------------------
Option Explicit
Private Const MAX_PATH = 260
Private Const INVALID_HANDLE_VALUE = (-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 'Unicode
cAlternate(1 To 14 * 2) As Byte 'Unicode
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 Const fATTR_READONLY As Long = &H1
Private Const fATTR_HIDDEN As Long = &H2
Private Const fATTR_SYSTEM As Long = &H4
Private Const fATTR_DIRECTORY As Long = &H10
Private Const fATTR_ARCHIVE As Long = &H20
Private Const fATTR_NORMAL As Long = &H80
'-------------------------------------------------------------
Sub Try_FindFile()
Dim myPath As String
Dim strFind As String
Dim f As String
Dim n&
Dim myList() As String
myPath = "D:\(Data)"
strFind = "abc.*"
FindFile myPath, strFind, myList(), n '★呼び出し
If n Then
MsgBox Join(myList, vbCr), , strFind & " ---> " & n & " Files"
Else
MsgBox "該当ファイルなし"
End If
End Sub
Private Sub FindFile(Pathname$, strFind$, myList$(), _
fCount&, Optional SearchChild As Boolean = True)
Dim p As String
Dim fDATA As WIN32_FIND_DATA
Dim lngAttribute As Long
Dim f As String
Dim hFile As Long
Dim SubDirs() As String, nSub As Long, i As Long
If Right$(Pathname, 1) <> "\" Then Pathname = Pathname & "\"
strFind = LCase$(strFind)
'まず 指定パス 直下の ファイルstrFindの検索をおこなう
lngAttribute = fATTR_NORMAL Or _
fATTR_READONLY Or _
fATTR_SYSTEM Or _
fATTR_HIDDEN Or _
fATTR_ARCHIVE
fDATA.dwFileAttributes = lngAttribute
p = Pathname & strFind
hFile = FindFirstFile(StrPtr(p), fDATA)
If hFile = INVALID_HANDLE_VALUE Then Exit Sub
Do
f = fDATA.cFileName
f = Left$(f, InStr(f, vbNullChar) - 1)
If (fDATA.dwFileAttributes And vbDirectory) = 0 Then
fCount = fCount + 1
ReDim Preserve myList(1 To fCount)
myList(fCount) = Pathname & f
End If
Loop While FindNextFile(hFile, fDATA)
FindClose hFile
'つぎに 指定パス 内のサブフォルダの検索をおこなう
If SearchChild Then
p = Pathname & "*.*"
fDATA.dwFileAttributes = fATTR_DIRECTORY
hFile = FindFirstFile(StrPtr(p), fDATA)
If hFile = INVALID_HANDLE_VALUE Then Exit Sub
Do
f = fDATA.cFileName
f = Left$(f, InStr(f, vbNullChar) - 1)
If (fDATA.dwFileAttributes And vbDirectory) Then
If Left$(f, 1) <> "." Then
nSub = nSub + 1
ReDim Preserve SubDirs(1 To nSub)
SubDirs(nSub) = Pathname & f
End If
End If
Loop While FindNextFile(hFile, fDATA)
FindClose hFile
If nSub Then
For i = 1 To nSub
FindFile SubDirs(i), strFind, myList(), fCount
Next
End If
End If
End Sub
|
|
kanabun
- 08/10/11(土) 11:13 -
