UACダイアログを回避して、管理者権限でプログラムを起動する

UAC、良いですよね。
いや、OSのアカウントと権限の管理がおかしいんじゃ、とかいう話はおいといて、良いと思います。
管理者アカウントでログオンしていても、単純には暴力がふるえない、と。

ただ、このプログラムではいちいち確認しないでよ、という人もいるようなので、
解決方法を調べてみた。

調べると

いろいろ出ますね。
たとえば、Windows7 UAC（ユーザーアカウント制御）対策 - 直天堂のカステラ
ただ、なんかステップが複雑。
vbsを使うなら、その辺自動化しようよ。
それに、スクリプトファイルが複数になるのも、好きじゃない。
ということで、書いてみた。
必要なのは、このファイルのみ。（くっつけただけだけど）

Option Explicit

Dim wsh, fso, path
Set wsh = CreateObject("WScript.Shell")
Set fso = CreateObject("Scripting.FileSystemObject")
path = ""
If WScript.Arguments.Named.Exists("mode") Then
	path = WScript.Arguments.Named("mode")
End if

If Len(path) > 0 Then
	If path = "start" Then
		Dim file, para, offset, l
		path = WScript.Arguments.Unnamed(0)
		l = Len(path)
		offset = InStr(path, ";")
		para = ""
		If offset > 0 Then
			para = Right(path, l - offset)
			path = Left(path, offset - 1)
		End if

		Set file = fso.GetFile(path)
		wsh.CurrentDirectory = fso.GetParentFolderName(file.ShortPath)
		wsh.Run "cmd.exe /c start /NORMAL " & file.ShortPath & " " & para, 0, False

	ElseIf path = "run" Then
		Dim task, taskFolder, tarTask, i, arg
		Set task = CreateObject("Schedule.Service")
		task.Connect
		Set taskFolder = task.GetFolder("\")
		Set tarTask = taskFolder.GetTask(WScript.ScriptName)
		arg = ""
		If WScript.Arguments.Named.Exists("arg") Then
			arg = ";" & WScript.Arguments.Named("arg")
		End if
		For i = 0 To WScript.Arguments.Unnamed.Count - 1
			tarTask.Run """" & WScript.Arguments.Unnamed(i) & arg & """"
			path = 100
			While tarTask.State <> 3 And path > 0
				WScript.Sleep(100)
				path = path - 1
			Wend
		Next

	ElseIf path = "delete" Then
		CreateObject("Shell.Application").ShellExecute "schtasks", "/delete /f /tn " & WScript.ScriptName, "", "runas"
		fso.DeleteFile wsh.SpecialFolders("SendTo") & "\" & WScript.ScriptName & ".lnk"

	Else
		WScript.Echo "Unknown mode :", path
	End if

Else
	If wsh.Run("schtasks /tn " + WScript.ScriptName, 0, True) > 0 Then
		Dim xmlFile, xmlPath, userId, pass
		If WScript.Arguments.Count > 2 Then
			userId = WScript.Arguments(2)
		Else
			userId = InputBox("起動用タスクを登録します。" & vbCrLf & "管理者アカウントを入力してください")
		End if
		xmlPath = fso.GetSpecialFolder(2) & "\" & fso.GetTempName()
		Set xmlFile = fso.CreateTextFile(xmlPath, True)
		xmlFile.WriteLine("<?xml version=""1.0"" encoding=""UTF-16""?><Task version=""1.2"" xmlns=""http://schemas.microsoft.com/windows/2004/02/mit/task""><RegistrationInfo /><Triggers /><Principals><Principal id=""Author""><RunLevel>HighestAvailable</RunLevel></Principal></Principals><Settings><DisallowStartIfOnBatteries>false</DisallowStartIfOnBatteries><Enabled>true</Enabled><Priority>4</Priority></Settings><Actions Context=""Author""><Exec><Command>" & WScript.ScriptFullName & "</Command><Arguments>/mode:start $(Arg0)</Arguments></Exec></Actions></Task>")
		xmlFile.Close
		If WScript.Arguments.Count > 3 Then
			pass = WScript.Arguments(3)
		Else
			pass = InputBox("パスワードを入力してください")
		End if
		CreateObject("Shell.Application").ShellExecute "schtasks", "/create /tn " & WScript.ScriptName & " /xml """ & xmlPath & """ /ru """ & userId & """ /rp """ & pass & """ /it", "", "runas"
		pass = 100
		While wsh.Run("schtasks /tn " + WScript.ScriptName, 0, True) > 0 And pass > 0
			WScript.Sleep(100)
			pass = pass - 1
		Wend
		fso.DeleteFile xmlPath
		If wsh.Run("schtasks /tn " + WScript.ScriptName, 0, True) > 0 Then
			WScript.Echo "タスクの作成に失敗しました"
			WScript.Quit 1
		End if
	End if

	Dim lnkPath, lnk, execPath
	If WScript.Arguments.Count = 0 Then
		If MsgBox("「送る」にショートカットを追加しますか？", vbYesNo) = vbYes Then
			lnkPath = wsh.SpecialFolders("SendTo") & "\" & WScript.ScriptName & ".lnk"
			Set lnk = wsh.CreateShortcut(lnkPath)
			lnk.TargetPath = fso.GetSpecialFolder(1) & "\wscript.exe"
			lnk.Arguments = WScript.ScriptFullName & " /mode:run"
			lnk.Save
		End if
	End if

	If WScript.Arguments.Count > 0 Then
		path = WScript.Arguments(0)
	Else
		path = InputBox("管理者権限実行ファイルを指定してください")
	End if
	If WScript.Arguments.Count > 1 Then
		lnkPath = WScript.Arguments(1)
	ElseIf Len(path) > 0 Then
		lnkPath = InputBox("実行用ショートカットの出力先を指定してください")
	End if
	If Len(path) > 0 And Len(lnkPath) > 0 Then
		If LCase(fso.GetExtensionName(lnkPath)) <> "lnk" Then
			lnkPath = lnkPath & ".lnk"
		End if
		Set lnk = wsh.CreateShortcut(lnkPath)
		lnk.TargetPath = WScript.ScriptFullName
		lnk.Arguments = "/mode:run " & path
		execPath = Split(path, ",")
		lnk.IconLocation = execPath(0) & ",0"
		lnk.Save
	End if
End if

使い方

好きなところに、スクリプトをおく
- VBScriptなので、拡張子は「.vbs」
- 場所を移動すると、タスクの再登録が必要になるので、ある程度計画的に
管理者権限のあるユーザーでスクリプトを実行する
- 最初はタスクがないので、タスクの登録が行われる
  - その際に、管理者権限のあるユーザー名とパスワードを聞かれる
  - ユーザー名とパスワードは、Windowsのタスクとして登録され、他には残りません
- 「送る」に登録すると、exeなりを右クリック→「送る」で管理者権限実行できます
  - 「送る」の表示名を変えたい場合は、Windowsキー＋Rから「shell:sendto」で開いたフォルダーにあるショートカットの名前を変更する
- 個別のショートカットを作成したい場合は、アプリケーションのパスと、ショートカットの作成場所を入力する
  - 作らない場合は、何も入力しなければ良い

「送る」や個別のショートカットはそれを実行するだけ。
コマンドラインから実行したい場合は、個別のショートカットでやっていることを見てください。
作成したタスクは、実行に引数が必要なので、schtasksでは実行できません。

動作原理

スクリプトを実行すると、必要タスクがなければ登録し、送るメニューや、管理者権限実行用ショートカット作成をする
管理者権限実行用ショートカットや送るメニューでは、Runモードで本スクリプトを実行する
Runモードでは、タスクを実行する（タスクは、Startモードで本スクリプトを実行する）
Startモードでは、対象プログラムを実行する

タスクが管理者権限実行することで、対象プログラムに管理者権限を付与しているわけです。

なお、送るメニューのショートカットとタスクについては、「/mode:delete」の引数でこのスクリプトを呼び出すと、削除されます。
個別に作成した管理者権限実行用ショートカットは手動削除をお願いします。

リスク

スクリプト名で作成される、タスクがセキュリティホールになりえます。
悪意のある人に、このタスクを知られると、問題になりますが、、、まあ、リスクは低そうです。
タスクはスクリプト名なので、ちょっと判りにくいものにすると良いかもしれません。

小技

WSHでは、名前あり引数と名前なし引数が別々に管理できます
タスクの状態は、3が準備完了、4が実行中
コマンドラインからタスクを作成すると、いろいろいじれない部分があるけど、xmlファイルからインポートすれば、なんでも設定可能
特殊フォルダーの取得は、Scripting.FileSystemObjectやWScript.Shellが使える
WScript.Shellを使ったショートカットの作成では、アイコンも設定できる