ファイルを探すプログラムで c:\のみ動かない

質問

ファイルを探すプログラムをネット頂き　テストしたのですが
c:\ のみ　動かず　c:\*** は　そのフォルダーから下を探します
e:\ は　全てのフォルダーを探します。
ＷＩＮ８　ですが　どこで間違ってるのでしょうか？
よろしくどうぞ

Option Explicit
Private g_dteDate As Date
Private g_strEXT As String

'参照設定　M-Scripting.Runtime

Cells(1, 2).Value　に　探すアドレス　記載　c:\ 　e:\ 　c:\*** など

Sub Sample_FileSearch2()

　　Dim vntF As Variant
Dim objFSO As FileSystemObject
Dim dteDate As Date
Dim GYO As Long
Dim cntFound As Long

Set objFSO = New FileSystemObject ' FSO
Rows("5:65536").ClearContents
GYO = 4
’ g_dteDate = DateAdd("m", Cells(3, 2).Value * -1, Date)　更新　不要
g_strEXT = UCase(Trim(Cells(2, 2).Value))

' ルートフォルダから探索開始
Call Sample_FileSearch2_SUB(objFSO, _
objFSO.GetFolder(Trim(Cells(1, 2).Value)), GYO, cntFound)
Set objFSO = Nothing
' 処理結果の表示
If cntFound = 0 Then
MsgBox "見つかりません"
Else
MsgBox cntFound & "個見つかりました"
End If
End Sub

'''*******************************************************************************
''' ファイル探索処理(再帰動作)
'''*******************************************************************************
Private Sub Sample_FileSearch2_SUB(objFSO As FileSystemObject, _
ByVal objFolder As Folder, _
GYO As Long, cntFound As Long)
Dim objFolder2 As Folder
Dim objFile As File

' サブフォルダの探索
For Each objFolder2 In objFolder.SubFolders
' サブフォルダ個々の探索(再帰動作)
Call Sample_FileSearch2_SUB(objFSO, objFolder2, GYO, cntFound)

Next objFolder2

' このフォルダ内のファイルの探索
For Each objFile In objFolder.Files
' ここから条件判断
With objFile
If (UCase(objFSO.GetBaseName(.Path)) = g_strEXT) Then

GYO = GYO + 1
Cells(GYO, 1).Value = .Name
Cells(GYO, 2).Value = .DateLastModified
Cells(GYO, 3).Value = _
Left(.Path, Len(.Path) - Len(.Name) - 1)
cntFound = cntFound + 1
End If
End With
Next objFile

End Sub

回答No.3

nda23 · ベストアンサー

該当フォルダの参照権を持つアカウントの
ユーザとパスワードが分かっていれば可能です。
特定の利用者にしか権限を与えないフォルダに
システム情報を記録して、一般ユーザから保護
するという仕組みはよく見られる手法です。

LogonUserで権限ユーザのトーケンを取得し、
ImpersonateLoggedOnUseで偽装します。偽装中は
フォルダを参照できます。
その後、RevertToSelfで偽装を終わり、処理後、
CloseHandleでトーケンを閉じます。
以下、サンプルです。

Const LOGON32_LOGON_INTERACTIVE As Long = 2
Const LOGON32_PROVIDER_DEFAULT As Long = 0
Declare Function LogonUser Lib "Advapi32" Alias "LogonUserA" _
　　　　(ByVal ユーザ As String, _
　　　　 ByVal ドメイン As String, _
　　　　 ByVal パスワード As String, _
　　　　 ByVal タイプ As Long, _
　　　　 ByVal プロバイダ As Long, _
　　　　 ByRef トーケン As Long) As Long
Declare Function ImpersonateLoggedOnUser Lib "Advapi32" _
　　　　(ByVal トーケン As Long) As Long
Declare Function RevertToSelf Lib "Advapi32" () As Long
Declare Function CloseHandle Lib "kernel32" _
　　　　(ByVal ハンドル As Long) As Long

Sub サンプル()
Dim トーケン As Long
Dim 処理結果 As Long

'★トーケン取得
処理結果 = LogonUser("uuuu", ".", "pppp" _
　　　　　　　　　, LOGON32_LOGON_INTERACTIVE _
　　　　　　　　　, LOGON32_PROVIDER_DEFAULT _
　　　　　　　　　, トーケン)
If 処理結果 = 0 Then
　　　　MsgBox "ログオンできない"
　　　　Exit Sub
End If
'★偽装開始
ImpersonateLoggedOnUser トーケン
'==
'= ここで該当フォルダの処理を行う
'==
'★偽装終了
RevertToSelf
'★トーケン解放
CloseHandle トーケン
End Sub

※上記はローカルアカウントのuuuu/ppppの例です。

但し、フォルダ毎に権限者が誰か調べたりする
必要があります。尚、権限が設定されていないと、
Administratorでも何も出来ません。
これも調べる方法、破る方法はあるんですが、さすがに
セキュリティに関することなので、一般公開できません。

ここまでするよりはエラーハンドリングで逃げたほうが
マシかも知れませんね。

お礼

ありがとうございます

コード参考にさせていただきます

>エラーハンドリングで逃げたほうがマシ

とりあえず、今これで目的は　何とかクリヤー、しかし、スマートじゃないかとも・・・

回答No.2

chie65536（@chie65535）

＞エクセル　ＶＢＡで　「システムフォルダをアクセス出来る権限を獲得しないと」
＞　って　可能でしょうか

VBAでWindows APIを呼べるのであれば、権限の獲得APIを呼べば良いだけだと思いますが、当方はやった事が無いので、出来るかどうか判りません。

他の博識な回答者の回答に期待します。

お礼

お手数おかけしました。感謝

回答No.1

chie65536（@chie65535）

C:のルート（C:\）や、C:のシステムフォルダ（C:\Windows\)などは、セキュリティ保護されているので、システムフォルダをアクセス出来る権限を獲得しないと、ファイル操作（検索、書き込み、読み込みなど）は出来ません。

補足

早速恐れ入ります。

やはり。

エクセル　ＶＢＡで　「システムフォルダをアクセス出来る権限を獲得しないと」
　って　可能でしょうか