| |
こんにちは よろしくお願いします
Application.FileSearch
でのフォルダ、ファイルの検索が遅いので
以前、高速なAPIで、フォルダ、ファイルの検索を教えて頂いた方法
（セルやイミディエイトウインドウに出力）
を、利用できないものかとチャレンジしましたがうまくいきません
やりたいことは
ファイルサーバーの所定のフォルダ配下には
重複するファイル名が存在しないことになっているのですが
時折、ファイルコピー等あったりして、キーで検索しても
複数存在したり、無かったりするものがあります
で、1ファイルだけの存在した場合場合、正常処理、そうでない場合は
メッセージを出したいと考えています
APIでの不具合の原因は、
他書への出力の場合は問題はないのですが
再帰のため戻り値や、配列に入れても最後の値しか取得できません
戻り値や配列の値が1つであれば
それを元に処理したいと考えています
APIはコピペ程度でしか利用できないレベルです
また、アプローチがおかしいような気もしています
ご教授よろしくお願い致します
下記は
配列を公開で宣言してそこに値を貯めこもうと考えました
Option Explicit
Option Compare Text
Private Type WIN32_FIND_DATAW
dwFileAttributes As Long
ftCreationTime(0 To 1) As Long
ftLastAccessTime(0 To 1) As Long
ftLastWriteTime(0 To 1) As Long
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName(0 To 519) As Byte
cAlternateFileName(0 To 27) As Byte
End Type
Private Declare Function FindFirstFileW Lib "kernel32" _
(lpFileName As Any, _
lpFindFileData As WIN32_FIND_DATAW) As Long
Private Declare Function FindNextFileW Lib "kernel32" _
(ByVal hFindFile As Long, _
lpFindFileData As WIN32_FIND_DATAW) As Long
Private Declare Function FindClose Lib "kernel32" _
(ByVal hFindFile As Long) As Long
Dim HAIRETSU() As String
' ファイルの検索 (NT系OS専用)
Sub SearchFiles3(ByVal strDir As String, strFind As String)
Static wfd As WIN32_FIND_DATAW
Dim strName As String
Dim hFile As Long
Dim I As Integer
Dim TG_PATH As String
I = 0
TG_PATH = ""
'GET_I = 0
'GET_PATH = ""
If StrComp(Right$(strDir, 1), "\", vbBinaryCompare) <> 0 Then
strDir = strDir & "\"
End If
' フォルダ(strDir)内の1件目を取得
hFile = FindFirstFileW(ByVal StrPtr(strDir & "*"), wfd)
If hFile = INVALID_HANDLE_VALUE Then
' この下の3行は消してもかまわない
If Err.LastDllError = ERROR_CALL_NOT_IMPLEMENTED Then
MsgBox "このOSでは動きません。", vbCritical
End If
Exit Sub
End If
Do
' ファイル(orフォルダ)名の取得
strName = wfd.cFileName
strName = Left$(strName, InStr(1, _
strName, vbNullChar, vbBinaryCompare) - 1)
'フォルダパス・ファイル部分一致
If strName Like "*" & strFind & "*" Then
' Debug.Print strDir & strName
TG_PATH = strDir & strName
I = I + 1
' Debug.Print I
ReDim HAIRETSU(I)
HAIRETSU(I) = strDir & strName
End If
' 属性の判定
If wfd.dwFileAttributes And vbDirectory Then
' フォルダの場合
If StrComp(strName, ".", vbBinaryCompare) <> 0 Then
If StrComp(strName, "..", vbBinaryCompare) <> 0 Then
' 再帰呼び出し
SearchFiles3 strDir & strName, strFind
End If
End If
End If
' 引き続き2件目以降を取得 (全件取得するまでループ)
Loop While FindNextFileW(hFile, wfd)
' ハンドルを閉じる
FindClose hFile
If I = 1 Then
Debug.Print "正"
Debug.Print TG_PATH
ElseIf I > 1 Then
Debug.Print "重複不整合"
'ループ分実行されてしまう
'Else
'Debug.Print "無し"
End If
End Sub
Public Sub test()
Call SearchFiles3("\\hoge", "huga")
Debug.Print HAIRETSU(1)
Debug.Print UBound(HAIRETSU)
End Sub
|
|
ON
- 08/10/10(金) 19:56 -
