Excel VBA Dirですべてのファイルをリスティングすることは失敗することがある

Dirの再帰呼び出しによりファイルを一覧を作る方法の検討

参考にするサイト

サブフォルダを含めてファイル一覧を取得する（Dir関数の再帰呼び出し）

次の場合うまくいかない

1. ファイルが大量にあるとき、処理が遅延する。
2. DocumentフォルダなどでAccessが禁止されるフォルダ。My Musicなど。これはFilesystemObjectを使っても同様の現象が起きる。
3. リムーバブルメディア等で読み取り専用フォルダに入ろうとした場合

Dir関数の制限について

今回の場合は関係がないが、上記に加えさらに

1. 256byteを超えると失敗する場合がある
2. 拡張子は3文字で前方一致

といった欠点がある

コード

Sub DirStart()
'https://www.moug.net/tech/exvba/0060088.html
cnt = 0
Call ReCursiveDir("D:\")
End Sub
Sub ReCursiveDir(Path As String)
If Not Path Like "*RECYCLE.BIN\*" And Not Path Like "*System Volume Information*" Then
Dim buf As String, f As Object
buf = Dir(Path & "\*.*")
Do While buf <> ""
cnt = cnt + 1
Cells(cnt, 1) = buf
buf = Dir()
Debug.Print Path & "\" & buf
Loop
With CreateObject("Scripting.FileSystemObject")
For Each f In .GetFolder(Path).SubFolders
Call ReCursiveDir(f.Path)
Next f
End With
End If
End Sub

FilesystemObject版

[VBA]サブフォルダ含むファイル一覧を再帰的に取得する
ここで紹介されている方法はexcelからフォームを前提としないものに書き換える。
Documentフォルダについて以下のマクロを起動するとアクセス禁止フォルダがスキップされる

Sub setFileList()
   'Filesystemobjectは参照設定必須です
   ’環境変数を使用してDocumentフォルダを指定しています
   'Dim WSH As New IWshRuntimeLibrary.WshShell
    With CreateObject("Wscript.Shell")
    Call getFileList(.ExpandEnvironmentStrings("%USERPROFILE%") & "\Documents")
   End With
End Sub
Sub getFileList(searchPath)
    Dim FSO As New FileSystemObject
    Dim objFiles As File
    Dim objFolders
    Dim separateNum As Long
   On Error GoTo Err_Handle
   
    'サブフォルダ取得
    For Each objFolders In FSO.GetFolder(searchPath).SubFolders
        Call getFileList(objFolders.Path)
    Next
    'ファイル名の取得
    For Each objFiles In FSO.GetFolder(searchPath).Files
        separateNum = InStrRev(objFiles.Path, "\")
       Debug.Print Left(objFiles.Path, separateNum - 1)
        Debug.Print Right(objFiles.Path, Len(objFiles.Path) - separateNum)
        Debug.Print FileDateTime(objFiles) & vbCrLf
   Next
Exit Sub
Err_Handle:
   Debug.Print searchPath, Err.Number, Err.Description, GetAttr(searchPath)
   Err.Clear
End Sub

Poweshellを使ってもダメだった

いったい何なのか

Window10の"%USERPROFILE%My Documents"の存在理由は？

Windows10 Pro Version 1703を使っています。
コマンドプロンプトを開いて
/> cd "%USERPROFILE%\My Documents"
を実行するとエラー無く「My Documents」というフォルダに移動できてしまいます。
しかし
/> echo hello > tmp.txt
/> dir
と実行しても「ファイルが見つかりません」となりtmp.txtは生成されず、
/> explorer .
を実行しても「場所が利用できません　アクセスが拒否されました。」というエラーダイアログが表示されるだけで、エクスプローラが開くこともありません。
Windows10には何のためにこのような変な動作になる"%USERPROFILE%\My Documents"が存在するのですか？
###答え
cmd.exeがディレクトリジャンクションを正しく扱えていないために発生している現象です。
以下のコマンドを実行してみてください。

/> dir /ah "%USERPROFILE%"

(略)

2017/04/07 11:33 My Documents [C:\Users****\Documents]
(略)
****は、実際にはユーザ名が入る。
/> cd "%USERPROFILE%\My Documents"

/> echo hello > tmp.txt

/> dir "%USERPROFILE%\My Documents"

→ファイルが見つかりません

/> dir "%USERPROFILE%\Documents"

?→tmp.txtファイルが存在する。

ディレクトリジャンクションとして、"%USERPROFILE%\My Documents"が存在しており、本体は"%USERPROFILE%\Documents"ディレクトリであることがわかります。昔のWindowsが、"%USERPROFILE%\My Documents"を標準ドキュメントディレクトリにしていて、最近のWindowsが"%USERPROFILE%\Documents"ディレクトリを標準ドキュメントディレクトリにしていることによる非互換の緩和のために作られているものですが、実際には書き込みをするときにはいいのですが、読み込もうとすると不具合でうまく扱えないことが多いです。通常不可視属性になっていますし、数セクタしか消費していませんので存在を無視すれば目くじらを立てるようなものではありません。

ディレクトリジャンクションは、シンボリッ****ンクやハード リンクとは異なり、他のドライブにあるディレクトリであっても、そのドライブにあるかのように偽装するリンクです。mklinkコマンドで作成できます。ディレクトリジャンクション自体は便利な機能なのですが、ディレクトリジャンクションがあることを想定していないアプリケーションでは不具合が発生することも多いです。

それなら

まずCmd.exeを管理者権限で起動し Dir /ahをやる
たしかに上記のJunctionが現れる。

cd "%USERPROFILE%\My Documents\My Videos"

上記と違いこういう風に打つと…現れた！

C:\uers\name\My Documents\My Videos>

Dirを入れてみる

C:\uers\name\My Documents\My Videos>Dir
C:\Users\name\My Documents\My Videos のディレクトリ

ファイルが見つかりません

正体は互換性のためにもうけられたMy Documentのフォルダ

このようにアクセスできる
だからといって Win+Rから"%USERPROFILE%\My Documents\My Videos"といれても拒否される。

現在のところ回避方法なし

VBA版のDirStartバージョンは外付けのディスクなどのシステム領域、ゴミ箱をフォルダ名を指定して回避するようにしています。しかしこれでもドキュメントフォルダは失敗します。