fileのリスト作成のマクロ

下記のマクロを組んでファイルのリストを作成しています。
しかし、Cドライブの「ユーザー」フォルダをターゲットとして動かすと、
途中でエラーが発生します。
純粋なデータだけのディレクトリであれば、問題はありません。
多分、見えないファイルが存在している為なのかと、考えていますが、
それに対する解決策もわかっていません。

汎用性を持たせるために、原因、及び対策を見つけたいと考えています。
宜しくお願い致します。

Option Explicit
Public cnt As Long

Sub FileCollection()
Dim TargetFolder As String
cnt = 0
TargetFolder = "C:\Users"
Call FileCollectionSub(TargetFolder)
End Sub

Sub FileCollectionSub(Path As String)
Dim buf As String
Dim f As Object

buf = Dir(Path & "\*.*")
With ActiveSheet
Do While buf <> ""
cnt = cnt + 1
.Cells(1 + cnt, 3).Value = Path & "\" & buf
buf = Dir()
Loop
End With

With CreateObject("Scripting.FileSystemObject")
For Each f In .GetFolder(Path).SubFolders
Call FileCollectionSub(f.Path)
Next f
End With
End Sub

質問者からの補足コメント

• ありがとうございます。
  かなり難しい話になったのだ・・・ということを理解しました。
  ひとつ気が付いたことがあります。
  WindFallerさんのルーチンでは、ファイル名に「/」が入ったものは、飛ばされます。
  小生の最初のルーチンでは「？」に化けて残ります。
  確かに、そんなファイル名をつける方が、おかしいのですが、存在していることは確かです。
  Dosプロンプトで、dir /s/b/o > list.txt で引っ張り出したものと、比較をしながら
  考えたいと思います。

  No.2の回答に寄せられた補足コメントです。 補足日時：2016/10/18 20:52

No.3 回答者： WindFaller 回答日時： 2016/10/21 17:09

こんにちは。

>ファイル名に「/」が入ったものは、飛ばされます。
それは、ありえないと思うのです。

ファイル名には、「　\　/：*　?　"　<　>　|」は、使えないから、入ってくる要素はないはずです。私は、今は、Windows10ですが、使えません。全角の場合は可能なのですが、そのあたりの問題を、ちょっと試すという気になれないのは、次の問題と同根のような気がするのです。

>小生の最初のルーチンでは「？」に化けて残ります。
>そんなファイル名をつける方が、おかしいのですが
ファイル名自体は、自動的につけるものがありますから、避けられませんね。例えば、Wordなどは、起きる可能性が高いです。

こちらが早合点しないためには、それは、何が化けているのかだけを注目したいですね。以下のリンク先で、すでに試みている人もいますから、それがつながりになるのか、どうかというところです。

今、Command プロンプトで確認すると、私のところでは、UTF-8 になっていました。しかし、こちらのFSOでは、ファイル名全体が抜けてしまいます。
正規表現のUnicodeブロックという手も考えましたが、さて範囲がどうなるのか以前に、文字認識しているかどうかも考えると、ややこしいと思います。できたとすれば、ブロックして、さしずめ、「x」にでも変えることになるでしょう。

今の段階では、私は、見通しが立っていません。
今の全体が古い方法で行っているから問題だと思っていましたが、多少の解決策はあるようです。

どうやら、質問の焦点というのは、Unicode(UTF-8)の問題のような気がします。まだ、私の先走りかもしれませんが、ここに、その話が出て来ているようですし、解決しているようです。
http://www.accessclub.jp/bbs5/0043/vba13611.html

まずは、文字化け部分の確認をお願いしたいです。

この回答へのお礼

ありがとうございます。
少し時間が経ってしまいました。
以下のことがわかりました。
Dos promptでの　Dir /s/b/o >1.txt で集めて、比較してみました。
①先に「/」について言及しましたが、再現できず。　－－－小生の間違いかと思います。
②fjiの on error GoTo ErrorHandler で飛ばすやり方でのリストと完全に一致しました。

On Error の方式は、もともとが、再帰呼び出しのプログラムですから、
On errorでまともに動くのか、と少し疑っていました。
結果は、まともそうです。理解はできていませんが。

正しくは、エラーの原因を明確にして、それを回避して、再帰呼び出しを
活用することだと思いますが、現時点では、それ以上には行っていません。

ところで、ディレクトリを掘り下げてリストを得るとしたら、再帰しかないと考えますが、別の考え方はあるのでしょうか？

宜しくお願い致します。

お礼日時：2016/10/30 18:53

No.2 回答者： WindFaller 回答日時： 2016/10/16 17:27

こんにちは。

ご質問のコードは、かなり古いものだと思います。
当時は、そのようなエラーは想定していなかったようです。

>見えないファイルが存在している為なのかと、
その対策自体は、以下の
= Dir(Path & "\*.*", vbNormal)
で済みます。

しかし、エラーになるのは、フォルダーのインデックス化の抑制が原因ではないでしょうか？いわゆる SpecialFolder で、特別な名前が付く所です。それから、思いつくエラー対策をあちこちに入れてみました。まだ、整理されていません。
取れない部分がありますが、それは別名でアクセスしなければなりません。

http://www.atmarkit.co.jp/ait/articles/1409/26/n …

例えば、My Music
そのためにこのような方法を思いつきました。

objFol.Attributes = 1046
なお、あえてエラートラップは入れませんでした。

'//

Public cnt As Long
Dim objFS As Object
Dim myFiles
Sub FileCollection()
Dim TargetFolder As String
cnt = 0
　ThisWorkbook.Activate
　ActiveSheet.Select
　TargetFolder = "C:\Users\[UserName]\Documents\"
'これ以上になるとエラーが発生します。
　ReDim myFiles(7000000)
　Application.ScreenUpdating = False
　Call FileCollectionSub(TargetFolder)
　Application.ScreenUpdating = True
　ReDim Preserve myFiles(cnt - 1)
　Cells(1, 3).Resize(cnt).Value = Application.Transpose(myFiles)

End Sub


Sub FileCollectionSub(Path As String)
　Dim buf As String
　Dim f As Object
　Dim objFol As Object
　 ' On Error GoTo ErrHandler
　If objFS Is Nothing Then
　　Set objFS = CreateObject("Scripting.FileSystemObject")
　End If
　Set objFol = objFS.getfolder(Path)
　If objFol.Attributes = 1046 Then Exit Sub
　buf = Dir(Path & "\*.*", vbNormal)
　With ActiveSheet
　　Do While buf <> ""
　　If Right(Path, 1) <> "\" Then Path = Path & "\"
　　　If objFS.FileExists(Path & buf) Then
　　　　Set objFol = objFS.getfolder(Path)
　　　　If objFol.Attributes <> 1046 Then
　　　　　If buf <> "." And buf <> ".." Then
　　　　　　If FileLen(Path & buf) > 0 And (GetAttr(Path & buf) And vbNormal) = vbNormal Then
　　　　　　　myFiles(cnt) = Path & buf '配列に格納
　　　　　　　'ここは不要
　　　　　　　''.Cells(1 + cnt, 3).Value = Path & "\" & buf
　　　　　　　cnt = cnt + 1
　　　　　　　''取得の状態をみる
　　　　　　　''Application.StatusBar = "counting..." & cnt
　　　　　　End If
　　　　　　DoEvents
　　　　　End If
　　　　End If
　　　End If
　　　buf = Dir()
　　Loop
　End With
　
　With objFS
　　For Each f In .getfolder(Path).subFolders
　　　If .FolderExists(f.Path) Then
　　　　Call FileCollectionSub(f.Path)
　　　End If
　　Next f
　End With
End Sub

No.1 回答者： fji 回答日時： 2016/10/15 19:14

アクセス権の無いディレクトリアクセスでエラーとなるため、例外処理を入れましょう。

Sub FileCollectionSub(Path As String) の次の行に、
「On Error GoTo ErrorHandler」を挿入

最後の行 End Sub の直前行に、
「ErrorHandler:」を挿入