サブフォルダ内のファイル名取得について

質問

Windows7 Access 2013環境です。
USB接続したハードディスク内のファイルリストを作成しようとしています。
ハードディスクはNTFSフォーマットです。

ボタン1をクリックしたとき、テーブル1をソースにしたフォーム1に
ファイル名を書き出していくようにしました。

ドライブ内のサブフォルダを選択すると、プログラムは正常に作動するのですが
ドライブ直下を指定すると、実行時エラー 70 "書き込みできません"
が発生します。

NTFSのアクセス権は、管理者でログインしているので、システム関連のフォルダ
System Volume Information
$RECYCLE.BIN
以外は問題ありません。

どこに問題があるのでしょうか。もし、システム関連のフォルダが
引っかかっているとしたら、その回避方法についても
具体的にご教授願います。

↓エラー箇所↓
--------------------------------------------------------------
For Each subfolder In folder.SubFolders
--------------------------------------------------------------

↓作成したプログラム↓
--------------------------------------------------------------
Private Sub ボタン_1_Click()

Dim dlg As FileDialog
Dim fold_path As String
Dim strTargetDir As String

DoCmd.GoToRecord acDataForm, "F0001_フォーム1", acNewRec

Set dlg = Application.FileDialog(msoFileDialogFolderPicker)

If dlg.Show = False Then Exit Sub

fold_path = dlg.SelectedItems(1)

strTargetDir = fold_path
Call FolderSearch(strTargetDir)
MsgBox "終了"

Set dlg = Nothing

Else

End If

End Sub

Public Sub FolderSearch(strTargetDir As String)

Dim fso As Object
Dim folder As Object
Dim subfolder As Object
Dim file As Object

Dim objFilsSys As Object
Dim objDrive As Object
Dim strDriveLetter As String

Set fso = CreateObject("Scripting.FileSystemObject")
Set folder = fso.GetFolder(strTargetDir)

strDriveLetter = Left(strTargetDir, 1)

Set objFileSys = CreateObject("Scripting.FileSystemObject")

Set objDrive = objFileSys.GetDrive(strDriveLetter)

For Each subfolder In folder.SubFolders　　←エラー箇所

FolderSearch subfolder.Path
Next subfolder

For Each file In folder.Files
With file
Me.ボリューム名 = objDrive.VolumeName
Me.ファイル名 = file.Name
Me.ファイルパス = folder.Path
Me.ファイルサイズ = folder.Size
DoCmd.GoToRecord acDataForm, "F0001_フォーム1", acNewRec
End With
Next file

Set objDrive = Nothing
Set fso = Nothing
Set folder = Nothing

End Sub

回答No.2

NotFound404 · ベストアンサー

すみません。かなり寝ぼけてました。。。
これでどうかな？（システムのあるCドライブでは失敗します）

Public Sub FolderSearch(strTargetDir As String)

Dim fso As Object
Dim folder As Object
Dim subFolder As Object
Dim file As Object

Dim objFileSys As Object
Dim objDrive As Object
Dim strDriveLetter As String

Set fso = CreateObject("Scripting.FileSystemObject")
Set folder = fso.GetFolder(strTargetDir)

strDriveLetter = Left(strTargetDir, 1)

Set objFileSys = CreateObject("Scripting.FileSystemObject")
Set objDrive = objFileSys.GetDrive(strDriveLetter)

For Each file In folder.Files
'With file
Me.ボリューム名 = objDrive.VolumeName
Me.ファイル名 = file.Name
Me.ファイルパス = folder.Path
Me.ファイルサイズ = folder.Size
DoCmd.GoToRecord acDataForm, "F0001_フォーム1", acNewRec
'End With
Next file

For Each subFolder In folder.SubFolders '←エラー箇所
If subFolder.Attributes <> 22 Then
FolderSearch subFolder.Path
End If
Next subFolder

Set objDrive = Nothing
Set fso = Nothing
Set folder = Nothing
End Sub

お礼

出来ました。ありがとうございます。記述する順序が、入れ替わったのは
わかるのですが、ループ処理をよくわかっていないので
今後勉強していこうと思います。

補足

出来ました。記述する順序が、入れ替わったのは
わかるのですが、ループ処理をよくわかっていないので
今後勉強していこうと思います。
ついでに、いままでAccessを終了するまで、USBハードディスクを
つかんだままになっていて、パソコンから外せなくなっていたのですが、
修正したところ、Accessを終了しなくても、取り外せるようになりました。

回答No.1

NotFound404

よく読んではいませんが、
フォルダの属性で判断してスキップするとかでは？
前略
For Each subfolder In folder.SubFolders　　←エラー箇所
if subfolder.attributes=22 then
FolderSearch subfolder.Path
end if
Next subfolder
後略

22 は
Directory 16
と
System 4
の論理和です。

補足

教えていただいた方法ですが、残念ながら回避できませんでした。