Word、Excel、PowerPoint 2007形式から旧形式へ

うちの職場、Office2007と、2007より古いOfficeとが混在しており、2007形式のファイルを旧形式で保存しなおすなんてことをよくやる。いちいち操作するのが面倒だったので、保存しなおす操作を自動でやるスクリプトを書いてみた。

自分は、Windows XP SP2(32bit版)、Office 2007 Professionalがインストールされている環境で使っている。

"ConvertToOldFormat.vbs"などといった名前で保存する。拡張子が".vbs"であれば名前は何でも良い。
"ConvertToOldFormat.vbs"に、"hoge.docx"など、2007形式のファイルをドロップすると、古い形式で保存されたファイルを作る。

'"ConvertToOldFormat.vbs"
'旧形式を表す定数。
Const wdFormatDocument = 0
Const xlExcel8 = 56
Const ppSaveAsPresentation = 1

Dim fso

Dim word
Dim excel
Dim powerPoint

Dim matches

Set word = Nothing
Set excel = Nothing
Set powerPoint = Nothing


Sub launchWord
	If word Is Nothing Then
		Set word = CreateObject("Word.Application")
		'word.Visible = True
	End If
End Sub

Sub launchExcel
	If excel Is Nothing Then
		Set excel = CreateObject("Excel.Application")
		'excel.Visible = True
	End If
End Sub

Sub launchPowerPoint
	If powerPoint Is Nothing Then
		Set powerPoint = CreateObject("PowerPoint.Application")
		'powerPoint.Visible = True
	End If
End Sub

Sub quitWord
	If Not word Is Nothing Then
		word.Quit
	End If
End Sub

Sub quitExcel
	If Not excel Is Nothing Then
		excel.Quit
	End If
End Sub

Sub quitPowerPoint
	If Not powerPoint Is Nothing Then
		powerPoint.Quit
	End If
End Sub


Set fso = CreateObject("Scripting.FileSystemObject")

Set wordRgx = New RegExp
wordRgx.Pattern = "^(.+)\.docx$"
wordRgx.IgnoreCase = True

Set excelRgx = New RegExp
excelRgx.Pattern = "^(.+)\.xlsx$"
excelRgx.IgnoreCase = True

Set powerPointRgx = New RegExp
powerPointRgx.Pattern = "^(.+)\.pptx$"
powerPointRgx.IgnoreCase = True


Set args = WScript.Arguments
If (args.Count > 0) Then
	For i = 0 To (args.Count - 1)
		filePath = args(i)
		'----------------------------------------------------------------
		'Word
		Set matches = wordRgx.Execute(filePath)
		If (matches.Count > 0) Then
			newFilePath = matches(0).SubMatches(0) & ".doc"
			launchWord
			Set wdDoc = word.Documents.Open(filePath)
			wdDoc.SaveAs newFilePath, wdFormatDocument
			wdDoc.Close
		End If
		'----------------------------------------------------------------
		'Excel
		Set matches = excelRgx.Execute(filePath)
		If (matches.Count > 0) Then
			newFilePath = matches(0).SubMatches(0) & ".xls"
			launchExcel
			Set xlDoc = excel.Workbooks.Open(filePath)
			xlDoc.SaveAs newFilePath, xlExcel8
			xlDoc.Close
		End If
		'----------------------------------------------------------------
		'PowerPoint
		Set matches = powerPointRgx.Execute(filePath)
		If (matches.Count > 0) Then
			newFilePath = matches(0).SubMatches(0) & ".ppt"
			launchPowerPoint
			Set ppDoc = powerPoint.Presentations.Open(filePath, True)
			ppDoc.SaveAs newFilePath, ppSaveAsPresentation
			ppDoc.Close
		End If
	Next
End If

MsgBox "終了しました。"

'後始末。
quitWord
quitExcel
quitPowerPoint