Option Explicit

Dim objFSO,objTxt,objShell,objFile,PROGRAMS, WINDIR, TEMP, COMMONPROGRAMS
Set objFSO = WScript.CreateObject("Scripting.FileSystemObject")
Const ForReading = 1, ForWriting = 2, ForAppending = 8
Set objTxt = objFSO.OpenTextFile("MSOffice1.txt", ForWriting, true, -2)
Set objShell = WScript.CreateObject("WScript.Shell")

'環境変数
WINDIR = objShell.ExpandEnvironmentStrings("%windir%")
PROGRAMS = objShell.ExpandEnvironmentStrings("%ProgramFiles%")
COMMONPROGRAMS = objShell.ExpandEnvironmentStrings("%CommonProgramFiles%")
TEMP = objShell.ExpandEnvironmentStrings("%Temp%")

Dim strAppName, strKey(), strValue()
Dim strFilePath()
Dim strURL()
Dim strSP

objTxt.WriteLine "****************************************************************"
objTxt.WriteLine "調査日時 : " & Date() & " - " & Time()
objTxt.WriteLine "****************************************************************"
objTxt.WriteBlankLines (1)

objTxt.WriteLine "Office を更新する"
objTxt.WriteLine "http://office.microsoft.com/ja-jp/downloads/HA011375481041.aspx"
objTxt.WriteBlankLines (1)

'Office 互換機能パック
Converter2007

Dim strOfficePath
strOfficePath = PROGRAMS & "\Microsoft Office\"

'Word,Excel,Outlook
Call MsOffice("Word", "WINWORD")
Call MsOffice("Excel", "EXCEL")
Call MsOffice("Outlook", "OUTLOOK")

objTxt.WriteBlankLines (1)

objTxt.Close
objShell.Run "MSOffice1.txt"
Set objTxt = Nothing
Set objFSO = Nothing
Set objShell = Nothing


'*********************************************************
'* Sub Converter2007
'*********************************************************
Sub Converter2007
	Dim objWI,prod, strConVName
	Set objWI = CreateObject("WindowsInstaller.Installer")
	For Each prod In objWI.Products
	    If UCase(Right(prod, 7)) = "0FF1CE}" Then
            strConVName = objWI.ProductInfo(prod, "ProductName")
		End If
	Next

	If IsEmpty(strConVName) Then
		Exit Sub
	ElseIf strConVName = "" Then
		Exit Sub
	End If

	Dim strConVPath
	strConVPath = COMMONPROGRAMS & "\Microsoft Shared\OFFICE12\MSO.DLL"
	strAppName = "Office 互換機能パック(Compatibility Pack for the 2007 Office system)"

	Redim strFilePath(4)
	If objFSO.FileExists(strConVPath) Then
		strFilePath(0) = strConVPath
	End If
MyFileVer
End Sub

'*********************************************************
'* Sub MsOffice
'*********************************************************
Sub MsOffice(strApp,strExe)
	strAppName = "Microsoft Office " & strApp
	strExe = strExe & ".EXE"
	Redim strFilePath(5)
	Redim strExPath(5)
	strExPath(0) = strOfficePath & strExe
	strExPath(1) = strOfficePath & "OFFICE\" & strExe
	strExPath(2) = strOfficePath & "OFFICE11\" & strExe
	strExPath(3) = strOfficePath & "OFFICE11\OFFICE11\" & strExe
	strExPath(4) = strOfficePath & "OFFICE10\" & strExe
	strExPath(5) = strOfficePath & "OFFICE10\OFFICE10\" & strExe
	Dim intX
	For intX = 0 To 5
		If  objFSO.FileExists(strExPath(intX)) Then
			strFilePath(intX) = strExPath(intX)
		End If
	Next
	Dim intY
	On Error Resume Next
	For intY = 0 To Ubound(strFilePath)
		If strFilePath(intY) <> "" Then MyFileVer
	Next
	On Error GoTo 0
End Sub


'*********************************************************
'* Sub MyFileVer -- ファイルのバージョンを表示
'*********************************************************
Sub MyFileVer
	objTxt.WriteLine "============================================================"
	objTxt.WriteLine " * " & strAppName
	objTxt.WriteLine "============================================================"
	Dim y
	For Each y in strFilePath
		If y <> "" Then
			Call ServicePack(objFSO.GetFileVersion(y))
			Dim x
			For Each x in strURL
				If x <> "" Then 
					objTxt.WriteLine x
					objTxt.WriteLine "------------------------------------------------------------"
				End If
			Next
			objTxt.WriteLine strSP
			objTxt.WriteBlankLines (1)
			objTxt.WriteLine "Path         : " & y
			objTxt.WriteLine "File version : "  & objFSO.GetFileVersion(y)
			Set objFile = objFSO.GetFile(y)
			objTxt.WriteLine "最終更新日時 : " & objFile.DateLastModified
			objTxt.WriteLine "サイズ       : " & Round(objFile.Size / 1024) & " KB"
		End If
	Next
	objTxt.WriteBlankLines (1)
	Set objFile = Nothing
End Sub

'*********************************************************
'* Sub ServicePack -- ServicePackのバージョン
'*********************************************************
Sub ServicePack(strVersion)
	Dim strOffice
	If InStr(strVersion, "11.0.") > 0 Then
	 strOffice = "Microsoft Office 2003"
	ElseIf  InStr(strVersion, "10.0.") > 0 Then
	 strOffice = "Microsoft Office XP(2002)"
	ElseIf  InStr(strVersion, "9.0.0") > 0 Then
	 strOffice = "Microsoft Office 2000"
	ElseIf InStr(strVersion, "12.0.") Then
	 strOffice = "Office 互換機能パック"
	End If
	Const s2003SP3_1 = "http://support.microsoft.com/kb/923618/ja"
	Const s2003SP3_2 = "http://www.microsoft.com/downloads/details.aspx?familyid=E25B7049-3E13-433B-B9D2-5E3C1132F206&displaylang=ja"
	Const s2002SP3_1 = "http://support.microsoft.com/kb/832671/ja"
	Const s2002SP3_2 = "http://www.microsoft.com/downloads/details.aspx?FamilyId=85AF7BFD-6F69-4289-8BD1-EB966BCDFB5E&displaylang=ja#filelist"
	Const s2000SP3_1 = "http://support.microsoft.com/kb/326585/ja"
	Const s2000SP3_2 = "http://www.microsoft.com/downloads/details.aspx?FamilyID=5C011C70-47D0-4306-9FA4-8E92D36332FE&displaylang=ja"
	Const sCONVSP1_1 = "http://support.microsoft.com/kb/953331/ja"
	Const sCONVSP1_2 = "http://www.microsoft.com/downloads/details.aspx?FamilyId=4F97AB2F-1F7D-49A3-9123-7CA3E703B916&displaylang=ja"
	
	Select Case strOffice
		Case "Office 互換機能パック"
			If myReplace(strVersion) >= 12064251000 Then
				strSP = strOffice & " Service Pack 2"
			ElseIf myReplace(strVersion) >= 12062131000 Then
				strSP = strOffice & " Service Pack 1"
				objTxt.WriteLine "! Service Pack 2 がインストールされていません"
			Else
				strSP = strOffice
				objTxt.WriteLine "! Service Pack 2 がインストールされていません"
				strURL(0) = sCONVSP1_1
				strURL(1) = sCONVSP1_2
			End If

		Case "Microsoft Office 2003"
			ReDim strURL(4)
			If myReplace(strVersion) >= 11081730 Then
				strSP = strOffice & " Service Pack 3"
			ElseIf myReplace(strVersion) >= 11079690 Then
				strSP = strOffice & " Service Pack 2"
				objTxt.WriteLine "! Service Pack 3 がインストールされていません"
				strURL(0) = s2003SP3_1
				strURL(1) = s2003SP3_2
			ElseIf myReplace(strVersion) >= 11063530 Then
				strSP = strOffice & " Service Pack 1"
				objTxt.WriteLine "! Service Pack 3 がインストールされていません"
				strURL(0) = s2003SP3_1
				strURL(1) = s2003SP3_2
			Else
				strSP = strOffice & "(Service Pack なし)"
				objTxt.WriteLine "! Service Pack 3 がインストールされていません"
				strURL(0) = s2003SP3_1
				strURL(1) = s2003SP3_2
			End If
		
		Case "Microsoft Office XP(2002)"
			If myReplace(strVersion) >= 10065010 Then
				strSP = strOffice & " Service Pack 3"
			ElseIf myReplace(strVersion) >=  10040240 Then
				strSP = strOffice & " Service Pack 2"
				objTxt.WriteLine "! Service Pack 3がインストールされていません"
				strURL(0) = s2002SP3_1
				strURL(1) = s2002SP3_2
			ElseIf myReplace(strVersion) >= 10034020 Then
				strSP = strOffice & " Service Pack 1"
				objTxt.WriteLine "! Service Pack 3 がインストールされていません"
				strURL(0) = s2002SP3_1
				strURL(1) = s2002SP3_2
			Else 
				strSP = strOffice & " Service Pack 3"
				objTxt.WriteLine "! Service Pack 3 がインストールされていません"
				strURL(0) = s2002SP3_1
				strURL(1) = s2002SP3_2
			End If
		
		Case "Microsoft Office 2000"
			If myReplace(strVersion) >= 9006604 Then
				strSP = strOffice & " Service Pack 3"
			ElseIf myReplace(strVersion) >= 9004430 Then
				strSP = strOffice & " Service Pack 2"
				objTxt.WriteLine strSP
				objTxt.WriteLine "! Service Pack 3 がインストールされていません"
				strURL(0) = s2000SP3_1
				strURL(1) = s2000SP3_2
			ElseI
				objTxt.WriteLine strSP
				objTxt.WriteLine "! Service Pack 3 がインストールされていません"
				strURL(0) = s2000SP3_1
				strURL(1) = s2000SP3_2
			End If
	End Select
End Sub

'*********************************************************
'* Function myReplace
'*********************************************************
Function myReplace(strVersion)
	myReplace = Replace(strVersion, ".", "")
End Function