フォルダー名一覧を作成するVBAでのエラー

ここで教えていただいたフォルダー名一覧を作成するVBAがあります。
共有ドライブやMyDocumentなどのサブフォルダーは綺麗に階層別に抜き出してくれて助かっています。
ところが、Cドライブ（ローカルディスク）に対して実行すると必ず「実行時エラー70　書き込みできません」になります。

ワークシートにそれまで記入されたフォルダー名を見ると [Config.Msi] となっています。
ただエクスプローラで見てもConfig.Msiというフォルダーは見当たりません。
おそらく隠しフォルダーなのでしょう。
Cドライブを検索する場合、隠しフォルダーは広わなくてもいいので、エラーにならないようするにはどう直せばよいのでしょうか？
エクセル2000です。

' [参照設定]・Microsoft Scripting Runtime

Option Explicit
Private g_cntPATH As Long

Sub SEARCH_FOLDER()
Dim objFSO As FileSystemObject
Dim strPATHNAME As String
Dim myObj As Object
Dim myDir As String

Set myObj = CreateObject("Shell.Application"). _
BrowseForFolder(0, "フォルダを選択してください", 0)
If myObj Is Nothing Then Exit Sub
If myObj = "デスクトップ" Then
myDir = CreateObject("WScript.Shell").SpecialFolders("Desktop")
Else
myDir = myObj.Items.Item.Path
End If
strPATHNAME = myDir
Cells.ClearContents
Set objFSO = New FileSystemObject
Call SEARCH_SUB_FOLDER(objFSO.GetFolder(strPATHNAME), 0, 0)
Set objFSO = Nothing
MsgBox "処理が完了しました。" & vbCr & vbCr & _
"フォルダ数=" & g_cntPATH & vbCr, vbInformation
End Sub

'フォルダ単位のサブ処理(再帰動作,引数はFile-Object,行,カラム)
Private Sub SEARCH_SUB_FOLDER(ByVal objPATH As Folder, ByRef GYO As Long, ByVal COL As Long)
Dim objPATH2 As Folder
g_cntPATH = g_cntPATH + 1 '参照フォルダ数を加算
GYO = GYO + 1 ' 行を加算
COL = COL + 1 ' カラムを加算
Cells(GYO, COL).Value = "[" & objPATH.Name & "]"
For Each objPATH2 In objPATH.SubFolders 'サブフォルダを探索するループ処理
Call SEARCH_SUB_FOLDER(objPATH2, GYO, COL) 'フォルダ単位のサブ処理(再帰呼び出し) ’←ここでエラー
Next objPATH2
Set objPATH = Nothing ' 参照OBJECTを破棄
End Sub

No.2 ベストアンサー 回答者： nicotinism 回答日時： 2011/05/31 11:54

お礼欄に書かれたモジュールをコピペして試したところ

すんなりと動きましたよ？
もしやと思い、管理者権限（Administrator）でないユーザで試したところ
Error 70 が発生しました。

どうも、一般ユーザでは、～<>22の処理は駄目っぽいような感じです。
質問者さんの権限はいかがですか？
エラートラップで逃げるしか手が無いかも？
On Error Goto ErrH
sub ～
処理
exit sub
ErrH:
select case err.number
case 70
resume next
case else
msgbox err.number & err.description
end select

この回答へのお礼

ありがとうございました。
管理者権限の問題でしたか・・・。

わたしは管理者ではないのでだめですね。
とりあえずOn Error Resume Nextでにげます。

有難うございました。

お礼日時：2011/05/31 15:17

No.1 回答者： nicotinism 回答日時： 2011/05/30 17:25

エラーが出るのはシステムフォルダを見に行った場合です。

WSH のヘルプの記述では
ファイルまたはフォルダの属性を設定します。値の取得も可能です。属性によっては、値の取得のみ可能な場合もあります。

object.Attributes [= newattributes]
引数
object
必ず指定します。File オブジェクトまたは Folder オブジェクトの名前を指定します。
newattributes
省略可能です。object に指定したファイルまたはフォルダに与える新しい属性値を指定します。
設定値
newattributes には、次に示す値を指定できます。また、複数の定数を組み合わせて、値の和を指定することもできます。

定数 値 内容
Normal 0 標準ファイル。どの属性も設定されません。
ReadOnly 1 読み取り専用ファイル。この属性は、値の取得も設定も可能です。
Hidden 2 隠しファイル。この属性は、値の取得も設定も可能です。
System 4 システム ファイル。この属性は、値の取得も設定も可能です。
Volume 8 ディスク ドライブ ボリューム ラベル。この属性は、値の取得のみ可能です。
Directory 16 フォルダまたはディレクトリ。この属性は、値の取得のみ可能です。
Archive 32 ファイルが前回のバックアップ以降に変更されているかどうか。この属性は、値の取得も設定も可能です。
Alias 64 リンクまたはショートカット。この属性は、値の取得のみ可能です。
Compressed 128 圧縮ファイル。この属性は、値の取得のみ可能です。
とのこと。

なので、エラー回避だけでしたら、16+4=22
For Each objPATH2 In objPATH.SubFolders 'サブフォルダを探索するループ処理
If objPATH2.Attributes <> 22 Then
～省略～
Windows 7 や Vista は分かりませんがWinXpならこれで良いかと。
On Error Resume Next で逃げてしまうというのもアリ？

この回答へのお礼

ありがとうございます。
システムフォルダを見に行った場合にエラーになるのですね。
以下のようにしてみましたが、やはり同じエラーが出ます。

エクセル2000(Win2000)
エクセル2003(WinXP) の両方で試しました。

なお、質問に書いたエラーの場所が1行ずれていました。すみません。
For Each objPATH2 In objPATH.SubFolders '←ここでエラーでした。

' [参照設定]・Microsoft Scripting Runtime

Option Explicit
Private g_cntPATH As Long

Sub SEARCH_FOLDER()
Dim objFSO As FileSystemObject
Dim strPATHNAME As String
Dim myObj As Object
Dim myDir As String

Set myObj = CreateObject("Shell.Application"). _
BrowseForFolder(0, "フォルダを選択してください", 0)
If myObj Is Nothing Then Exit Sub
If myObj = "デスクトップ" Then
myDir = CreateObject("WScript.Shell").SpecialFolders("Desktop")
Else
myDir = myObj.Items.Item.Path
End If
strPATHNAME = myDir
Cells.ClearContents
Set objFSO = New FileSystemObject
Call SEARCH_SUB_FOLDER(objFSO.GetFolder(strPATHNAME), 0, 0)
Set objFSO = Nothing
MsgBox "処理が完了しました。" & vbCr & vbCr & _
"フォルダ数=" & g_cntPATH & vbCr, vbInformation
End Sub

'フォルダ単位のサブ処理(再帰動作,引数はFile-Object,行,カラム)
Private Sub SEARCH_SUB_FOLDER(ByVal objPATH As Folder, ByRef GYO As Long, ByVal COL As Long)
Dim objPATH2 As Folder
g_cntPATH = g_cntPATH + 1 '参照フォルダ数を加算
GYO = GYO + 1 ' 行を加算
COL = COL + 1 ' カラムを加算
Cells(GYO, COL).Value = "[" & objPATH.Name & "]"
For Each objPATH2 In objPATH.SubFolders 'サブフォルダを探索するループ処理’←ここでエラー
If objPATH2.Attributes <> 22 Then
Call SEARCH_SUB_FOLDER(objPATH2, GYO, COL) 'フォルダ単位のサブ処理(再帰呼び出し)
End If
Next objPATH2
Set objPATH = Nothing ' 参照OBJECTを破棄
End Sub

お礼日時：2011/05/31 09:09