VBScriptでショートカットのリンク先をまとめて書き換えるやつ

はじめに

ファイルサーバをリプレースしたものの、ホスト名やIPアドレスが変更になってしまった。

ドメインのグループポリシーで共有フォルダ宛のショートカットの書き換えはできるが、
各端末上にはユーザーが独自に作成した旧ファイルサーバ宛のショートカットが存在しており、それらまで書き換えることは不可能。
かといって、それらをすべてを手動で作り直してくれとユーザーにお願いするのは気が引ける……

仕方ないので、VBScriptの力を借りて自動的にリンク先を書き換えてもらうことにした。

環境

• Windows 7/8.1/10/11 混在環境

実例

以下のプログラム例は下記ウェブページにて公開されているものを改変した。

https://www.depthbomb.net/?p=4941

基本的な動作の説明は上記ページを参照して頂きたい。

独自に改変したポイントとしては下記の通り。

• ショートカット書き換えサブルーチン(ShortCutPathReplace)に対し、必要な情報をグローバル変数ではなく引数で渡すこととした。
• 書き換え元のパスを配列で指定するようにした。
  それにより、IPアドレスだけでなくホスト名宛で作られているショートカットについても対象とできるようになった。
• リンク先判定処理において、大文字小文字の区別をしないようにした。
• リンク先判定処理において、条件に合致しショートカットの書き換えが行われた場合は、以後の条件について判定をスキップすることにした。
  複数回リンク先が置換されてしまうことを防ぐため。
• リンク先書き換え処理において、作業フォルダ判定をリンク先判定の中にネストした。
  それにより、処理の高速化を実現した。
  （リンク先が対象外の場所で、かつ作業フォルダが対象の場所だった場合は残ったままになるが、レアケースとして目をつぶる）

replaceshortcuts.vbs

Option Explicit

Call Main()

Sub Main()
	Dim objFS
	Dim objShell
	Dim TargetPath
	
	Dim strOldHosts
	Dim strNewHost
	
	' 置換元・先の指定
	strOldHosts = Array("\\192.168.15.180", "\\FILE")
	strNewHost = "\\192.168.15.181"
	
	'デスクトップのファルダパスを取得 (対象フォルダを手動で指定する場合は直接代入する)
	' TargetPath = "C:\path\to\target\folder"
	Set objShell = CreateObject("WScript.Shell")
	TargetPath = objShell.SpecialFolders("Desktop")
	
	
	Set objFS = CreateObject("Scripting.FileSystemObject")
	'ショートカット書き換えサブルーチン起動
	Call ShortCutPathReplace(objFS.GetFolder(TargetPath), strOldHosts, strNewHost)

	'オブジェクトを破棄します。
	Set objFS = Nothing
	Set objShell = Nothing

	msgbox "ショートカットファイルのリンク先変更が完了しました。"
End Sub


'引数で渡されたフォルダのパスとその配下のサブフォルダ全てを再帰的に走査し、
'ショートカットファイルのリンク先を書き換える
Sub ShortCutPathReplace(ByVal objBaseFolder, ByVal strOldHosts(), ByVal strNewHost)
	Dim objFS
	Dim objSubFolder
	Dim objFile
	Dim objShell
	Dim objShellLink
	Dim ShortCutPath
	Dim WorkDirPath
	
	Set objFS = CreateObject("Scripting.FileSystemObject")
	Set objShell = CreateObject("WScript.Shell")
	
	'サブフォルダを再帰的に走査
	For Each objSubFolder In objBaseFolder.SubFolders
		Call ShortCutPathReplace(objSubFolder, strOldHosts, strNewHost)
	Next
	
	'フォルダ内の全てのファイルを走査
	For Each objFile In objBaseFolder.files
	
		'ファイルパスの拡張子を判定
		If objFS.GetExtensionName(objFile.Path) = "lnk" Then
		
			'ショートカットのオブジェクトを生成
			Set objShellLink = objShell.CreateShortcut(objFile.Path)
			'ショートカットのリンク先を取得
			ShortCutPath = objShellLink.TargetPath
			'作業フォルダのパスを取得
			WorkDirPath = objShellLink.WorkingDirectory
			
			On Error Resume Next
			
			Dim strOldHost
			For Each strOldHost In strOldHosts
		
				'ショートカットのリンク先が書き換え対象かを判定
				If Left(LCase(ShortCutPath), Len(strOldHost)) = LCase(strOldHost) Then
					'リンク先パスを書き換え
					objShellLink.TargetPath = Replace(ShortCutPath,strOldHost,strNewHost)
					'リンク先の変更を保存
					objShellLink.Save
				
					'ショートカットの作業フォルダが書き換え対象かを判別
					'※ショートカットがフォルダの場合は作業フォルダは空なのでIFの判定でFalseになり無視される
					If Left(LCase(WorkDirPath), Len(strOldHost)) = LCase(strOldHost) Then
						objShellLink.WorkingDirectory = Replace(WorkDirPath,strOldHost,strNewHost)
						'作業フォルダの変更を保存
						objShellLink.Save
					End If
					
					'エラー処理
					If Err.Number <> 0 Then
						'エラーが出た場合は、msgboxでエラー対象のショートカットファイルを通知
						msgbox "以下のショートカットファイルのリンク先書き換え処理でエラーが発生しました。" _
							& vbcrlf & vbcrlf & objFile.Path
					End If
					
					'エラーを初期化
					On Error Goto 0
					
					Exit For
				End If
			Next
		End If
	Next
	
	'オブジェクトを破棄
	Set objFile = Nothing
	Set objSubFolder = Nothing
	Set objShellLink = Nothing
	Set objFS = Nothing
	Set objShell = Nothing
End Sub

展開方法

このスクリプトをUSBメモリ等に入れて全端末を行脚してもいいし
ドメインコントローラが存在するのであれば、自動消滅するバッチファイルを配信してそれ経由で実行するとかで自動化できるかもしれない

ハマるかもしれないポイント

リンク先の表記ゆれ

書き換え要・不要については前方一致で判断している。

たとえば「\\file.localdomain」とFQDNで指定されているショートカットが存在している環境下で、「\\file」を「\\file2.localdomain」に書き換える、とした場合
結果は「\\file2.localdomain.localdomain」となり、事故ってしまう。

同様に「\\file」と指定されているショートカットが存在している環境に対し、「\\file.localdomain」を「\\file2.localdomain」に書き換える、とした場合も空振りして失敗してしまう。

対策としては、長いものから先に判定してマッチさせておけばよい。

例

	strOldHosts = Array("\\192.168.15.180", "\\FILE.LOCALDOMAIN", "\\FILE")
	strNewHost = "\\192.168.15.181"

おわりに

たぶん動くと思いますが、事前検証した上で使ってください。

不具合があった場合はこっそり教えてください……