Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


13802 / 76738 ←次へ | 前へ→

【68438】Re:階層の深いファイルが読み取れない
発言  kanabun  - 11/3/5(土) 23:53 -

引用なし
パスワード
   ▼ミーコ さん:こんにちは〜

>以前にこちらで質問したミーコです。
以前回答しました 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

1 hits

【68437】階層の深いファイルが読み取れない ミーコ 11/3/5(土) 22:27 質問
【68438】Re:階層の深いファイルが読み取れない kanabun 11/3/5(土) 23:53 発言
【68439】Re:階層の深いファイルが読み取れない ミーコ 11/3/6(日) 1:04 お礼

13802 / 76738 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free