| |
▼ミーコ さん：こんにちは〜
>以前にこちらで質問したミーコです。
以前回答しました kanabun です(^^
>コードを教えてもらいました。
>ただ、どうも
>
> fList = SubDir("C:\Documents and Settings\AAA\*.xls")
>
>の部分で、階層の深いファイルが読み取れない現象が生じています。
DOSのDirコマンドですと文字数の制限があったかもしれないですね。
なので、FindFile API というのを使ってみましょう。
Sub Try2() の
> LookIn = "C:\Documents and Settings\AAA\" ' 検索Rootフォルダ
> strFind = "*.xls" ' 検索ファイル名
・LookIn に 検索Topフォルダ、
・strFind に検索ファイルパターン
を入れてお試しください。
これなら、深い階層でも、またファイル名がUnicode（たとえばアラビア語）
でも、検索できると思います。
なお、
結果はシートに出力するようにしましたので、
問い合わせがあったら マウスで書き出す先頭セルを指定してやってください。
'------------------------------------------------ もう一つの標準モジュール
Option Explicit
Private Const MAX_PATH = 260
Private Const INVALID_HANDLE_VALUE = (-1)
'WIN32_FIND_DATA構造体
Private Type WIN32_FIND_DATA
dwFileAttributes As Long
fileTime(1 To 3) As Currency
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved(1) 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
Sub Try2()
Dim LookIn As String '検索パス
Dim strFind As String '検索ファイル名
Dim FoundFiles() As String
Dim nCount As Long
Dim nMax As Long
Dim i As Long
'''検索パスとファイル拡張子を指定してSubDir付き検索
LookIn = "C:\Documents and Settings\AAA\" ' 検索Rootフォルダ
strFind = "*.xls" ' 検索ファイル名
ReDim FoundFiles(1 To 500)
FindFile LookIn, strFind, FoundFiles(), nCount, nMax
If nCount > 0 Then
Dim r As Range
On Error Resume Next
Set r = Application. _
InputBox("ファイルリスト どこに書き出しますか？", Type:=8)
On Error GoTo 0
If r Is Nothing Then Exit Sub
r.Resize(nCount).Value = Application.Transpose(FoundFiles())
End If
Beep
End Sub
'サブフォルダを含むファイルの検索
Private Sub FindFile(strDir As String, strFind As String, _
FoundFiles() As String, fCount As Long, nMax As Long)
Dim p As String
Dim fDATA As WIN32_FIND_DATA
Dim f As String
Dim hFile As Long
Dim SubDir() As String, nSub As Long
If Right$(strDir, 1) <> "\" Then strDir = strDir & "\"
strFind = LCase$(strFind)
p = strDir & "*.*"
'サブフォルダを含む全てのファイルの検索
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 '<File> なら
If LCase$(f) Like strFind Then
fCount = fCount + 1
If fCount > nMax Then
nMax = nMax + 500
ReDim Preserve FoundFiles(1 To nMax)
End If
FoundFiles(fCount) = strDir & f
End If
ElseIf Left$(f, 1) <> "." Then '<SubFolder>なら
nSub = nSub + 1
ReDim Preserve SubDir(1 To nSub)
SubDir(nSub) = strDir & f
End If
Loop While FindNextFile(hFile, fDATA)
FindClose hFile
If nSub > 0 Then
Dim i As Long
For i = 1 To nSub
FindFile SubDir(i), strFind, FoundFiles(), fCount, nMax
Next
End If
End Sub
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
