特殊フォルダ内の検索とショートカット作成について

質問

こんにちわ。VBSをはじめて間もないのですが、宜しくお願いします。

現在、C:\Documents and Settings\<各ユーザー名>\SendTo 内を検索し、
該当の.lnkがあった場合に、全てユーザーのリンク先を変更するというプログラムを作成しています。

WshShell.SpecialFolders("SendTo")を利用した場合、ログオンしている
ユーザーの.lnkは変更できるのですが、他のユーザーの.lnkが変更できません。

また、テストをおこなっている端末により、「C:\Documents and Settings\Administrator」の
フォルダの読み込み？ができずにエラーになってしまいます。

C:\Documents and Settings\Administrator内のファイルへのアクセス
権の変更？
と全ユーザーのフォルダ内の特定ファイルの変更について教えてください。宜しくお願い致します。
-----------------------------------------------------
Const Find_Dir ="C:\Documents and Settings\"
Dim strFileList

Set objFso = CreateObject("Scripting.FileSystemObject")
Set objFol = objFso.GetFolder(Find_Dir)
Set colFiles = objFol.Files
Set colFolders = objFol.subFolders

FileFind(objFol)
Set objFol = Nothing
Set objFso = Nothing

wscript.Echo("完了")

Sub FileFind(objFol)
Dim objFile, objSubFolder
For Each objFile In objFol.Files
　　 if (objFile.Name = "テスト.lnk") then
Ioc()
else
wscript.Quit
end if
Next

For Each objSubFolder In objFol.SubFolders
FileFind(objSubFolder)
Next

End Sub

Sub Ioc()
Set WshShell = Wscript.CreateObject("Wscript.Shell")
IocSend = WshShell.SpecialFolders("SendTo")
srtCutName = IocSend & "\テスト.lnk"
Set SIcon = WshShell.CreateShortcut(srtCutName)
with SIcon
.TargetPath ="\\test\test.exe"
.HotKey=""
.Arguments =""
.Description =""
.WorkingDirectory=""
.IconLocation = "shell32.dll,44"
.WindowStyle= 1
.Save
end with
end Sub

回答No.1

SHIMAPEE · ベストアンサー

ご要望とは違ってしまいますが、本スクリプトは「管理者権限のあるアカウントで実行する」ことにしてはどうでしょうか。権限のないユーザがAdmin含め他のユーザのデータを書き換えできたら危険ですよね。

権限のないユーザでもコマンドプロンプトからrunasコマンドを使えば管理者権限で実行できます（ユーザ名とパスワードの入力が必要）。

また、WshShell.SpecialFolders("SendTo")を使わなくても、フォルダ名と文字列"SendTo"を連結すれば目的のフォルダにアクセスできます。

下のコード、及びrunasコマンドを使っての実行はWindows XP Pro SP3で確認しました。

-----
Option Explicit
Const Find_Dir ="C:\Documents and Settings\"
Dim strFileList
Dim WshShell, objFso, objFol, objUserFolder

Set WshShell = Wscript.CreateObject("Wscript.Shell")
Set objFso = CreateObject("Scripting.FileSystemObject")
Set objFol = objFso.GetFolder(Find_Dir)

For Each objUserFolder In objFol.SubFolders
if objFso.FolderExists(Find_Dir & objUserFolder.Name & "\SendTo") then
FileFind(Find_Dir & objUserFolder.Name & "\SendTo")
end if
Next

Set objFol = Nothing
Set objFso = Nothing

wscript.Echo("完了")

Sub FileFind(strSendToFol)
Dim objSendToFol, objFile, objSubFolder
'WScript.Echo "FileFind " & strSendToFol '検索フォルダの確認
Set objSendToFol = objFso.GetFolder(strSendToFol)
For Each objFile In objSendToFol.Files
if (objFile.Name = "テスト.lnk") then
Ioc(strSendToFol & "\" & "テスト.lnk")
end if
Next

For Each objSubFolder In objSendToFol.SubFolders
FileFind(strSendToFol & "\" & objSubFolder.Name)
Next
End Sub

Sub Ioc(strCutName)
Dim SIcon
'WScript.Echo "Ioc " & strCutName '変更ショートカットの確認
Set SIcon = WshShell.CreateShortcut(strCutName)
with SIcon
.TargetPath ="\\test\test.exe"
.HotKey=""
.Arguments =""
.Description =""
.WorkingDirectory=""
.IconLocation = "shell32.dll,44"
.WindowStyle= 1
.Save
end with
end Sub
-----

なお、本スクリプトの根本的な仕様についてですが、「該当の.lnk」とは、ファイル名ではなく、TargetPathを見て決定すべきではないでしょうか（"\\xxx\yyy.exe"を"\\test\test.exe"に変更したいのではないでしょうか）。また、ショートカットがデスクトップなどに作成・コピーされていることもあるのでは。

もしそうだとすると、.lnkファイル全てについてTargetPathを確認し、該当すれば変更するように、また検索フォルダは"C:\Documents and Settings\"全体にしなければなりません。

考え過ぎでしたらすみません。

お礼

SHIMAPEEさん

特殊フォルダであっても、フォルダ名と文字列でアクセス出来るなんて
知りませんでした。ありがとうございます。

スクリプトの実行についても、管理者以外が実行するのは確かに困りますね・・・
もう少し実用について考えるようにしてみます。

WinXP Pro SP2では、runasでエラーになりますが、これくらいは自分で調べてみます。

ちなみに、今回のスクリプトは該当フォルダ内の該当ファイルのみを
対象しているので、.lnk全てについてTargetPathを確認する必要はあり
ません。いろいろ考えていただいてありがとうございます。