Officeファイルを読み取り専用で開くスクリプト

Option Explicit

'変数宣言
Dim count

'引数がないときはプログラム終了
If WScript.Arguments.count < 1 Then
	InputBox ""
	WScript.Quit
End If

'ファイル数の分だけ繰り返す
For count = 0 To (WScript.Arguments.Count - 1) Step 1

	'変数宣言
	Dim strFile
	Dim strType
	Dim objFS
	Dim objFile
	Dim objOffice

	'引数を取得
	strFile = WScript.Arguments(count)
	Set objFS = CreateObject("Scripting.FileSystemObject")

	'存在チェック
	If objFS.FileExists(strFile) Then
		Set objFile = objFS.GetFile(strFile)
		strType = objFile.Type
		
		'ショートカットの場合
		If StrComp(strType, "ショートカット") = 0 Then
			GetLinkPath
		End If
		
		'Excelの場合
		If InStr(strType, "Microsoft Excel") <> 0 Then
			Set objOffice = WScript.CreateObject("Excel.Application")
			objOffice.Visible = True
			
			'アクティブ化
			WScript.CreateObject("WScript.Shell").AppActivate (objOffice.Caption)
			
			'ウィンドウサイズ
			objOffice.WindowState = -4137 '最大化
			'objOffice.WindowState = -4140 '最小化
			'objOffice.WindowState = -4143 '標準
			
			'読み取り専用で開く
			Call objOffice.Workbooks.Open(strFile, , True)
			
			'終了時の保存確認なし
			objOffice.DisplayAlerts = False
			
		'Wordの場合
		ElseIf InStr(strType, "Microsoft Word") <> 0 Then
			Set objOffice = WScript.CreateObject("Word.Application")
			objOffice.Visible = True
			
			'アクティブ化
			WScript.CreateObject("WScript.Shell").AppActivate (objOffice.Caption)
			
			'ウィンドウサイズ
			objOffice.WindowState = 1 '最大化
			'objOffice.WindowState = 2 '最小化
			'objOffice.WindowState = 0 '標準
			
			'読み取り専用（印刷レイアウト）
			Call objOffice.documents.Open(strFile, , True)
			objOffice.ActiveWindow.View = 3
			
		'PowerPointの場合
		ElseIf InStr(strType, "Microsoft PowerPoint") <> 0 Then
			Set objOffice = WScript.CreateObject("Powerpoint.Application")
			objOffice.Visible = True
			
			'アクティブ化
			WScript.CreateObject("WScript.Shell").AppActivate (objOffice.Caption)
			
			'ウィンドウサイズ
			objOffice.WindowState = 3 '最大化
			'objOffice.WindowState = 2 '最小化
			'objOffice.WindowState = 1 '標準
			
			'読み取り専用で開く
			Call objOffice.Presentations.Open(strFile, True)
			
		'それ以外の場合
		Else
			If StrComp(strType, "ERROR") <> 0 Then
			
			'エラー出力
			MsgBox "「"&strType&"」は未対応です。", vbExclamation Or vbSystemModal, "ファイル不正"
			
			End If
		End If
		
	Else
		MsgBox "「" & strFile & "」は存在しません。", vbExclamation Or vbSystemModal, "エラー"
	End If

	'終了処理
	Set strFile = Nothing
	Set strType = Nothing
	Set objFS = Nothing
	Set objFile = Nothing
	Set objOffice = Nothing
Next

'終了処理
Set count = Nothing
WScript.Quit

Sub GetLinkPath()

	'変数宣言
	Dim objShell
	Dim objLink
	Dim strPath
	
	'エラーが発生しても継続
	On Error Resume Next
	
	'リンク先のファイルパスを取得
	Set objShell = WScript.CreateObject("WScript.Shell")
	Set objLink = objShell.CreateShortcut(strFile)
	strPath = objLink.TargetPath
	
	'ファイル種別の更新
	Set objFile = objFS.getfile(strPath)
	strType = objFile.Type
	
	'例外処理
	If Err.Number <> 0 Then
		MsgBox "リンク先のファイルが読み込めません。", vbCritical Or vbSystemModal, "処理中断"
		strType = "ERROR"
	End If
	
	'終了処理
	Set objShell = Nothing
	Set objLink = Nothing
	Set strPath = Nothing
	
End Sub