スクリプトを実行したフォルダ内のPowerPointファイルから画像を抽出
色の再現度がJPGよりPNGの方が良かったので設定（変更も可能）
読み込みフォルダも出力フォルダもカレントディレクトリにしているが、固定で指定することも可能
ファイル名の半角空白があると誤動作して、プロセスにPowerPointが残り、手動で終了させないといけなくなるので、半角の空白はアンダーバーで置き換える処理を先にする
注意 このブログは、’と“”が全角に置き換わるので、vbsファイルへコピー後に、半角のシングルクォーテーションと半角のダブルクォーテーションに置き換えること
※ “と”をダブルクォーテーションに置き換える
pptxファイルから画像ファイルを抽出.vbs のサンプルコード
Option Explicit
‘************************
‘ myPathで指定したフォルダ内ファイルに含まれる半角空白を_に置き換える
Dim after
Dim objFolder
Dim objFile
Dim objFileSys
Dim strExtension
Dim myPath
Dim objShell
Set objShell = CreateObject( “WScript.Shell” )
myPath = objShell.CurrentDirectory
Set objShell = Nothing
‘ファイルシステムを扱うオブジェクトを作成
Set objFile = CreateObject(“Scripting.FileSystemObject”)
Set objFileSys = CreateObject(“Scripting.FileSystemObject”) ‘拡張子取得用
‘フォルダのオブジェクトを取得
Set objFolder = objFile.GetFolder(myPath)
‘FolderオブジェクトのFilesプロパティからFileオブジェクトを取得
For Each objFile In objFolder.Files
‘ファイルの拡張子を取得
strExtension = objFileSys.GetExtensionName(objFile.Name)
If strExtension = “pptx” Then
If InStr(objFile.Name,” “) Then ‘空白を含む場合のみ処理
after = Replace(objFile.Name,” “,”_”)
‘ファイル名変更
objFile.Name = after
End If
End If
Next
Set objFile = Nothing
Set objFileSys = Nothing
‘***********************必要な設定をppSaveAsXXXで指定
Const ppSaveAsBMP = 19
Const ppSaveAsPNG = 18
Const ppSaveAsJPG = 17
Const ppSaveAsGIF = 16
Const ppSaveAsHTML = 12
Const ppSaveAsDefault = 11
Const ppSaveAsPDF = 32
Const ppSaveAsPowerPoint3 = 4
Const ppSaveAsPowerPoint4 = 3
Const ppSaveAsPowerPoint7 = 2
Dim fname, ppt
‘ File System Object
Dim objFso
Set objFso = CreateObject(“Scripting.FileSystemObject”)
‘ Wsh Shell
Dim objWshShell
Set objWshShell = WScript.CreateObject(“WScript.Shell”)
Dim strPath
Dim outPath
Dim imgName
Set objShell = CreateObject( “WScript.Shell” )
strPath = objShell.CurrentDirectory
Set objShell = Nothing
Dim obj ‘As Object
For Each obj In objFso.getfolder(strPath).Files
If Right(obj.Name,5) = “.pptx” and Left(obj.Name,1) <> “~” Then ‘~$の一時ファイルが残っていてエラーとなることあったので対策
fname = strPath & “\” & obj.Name
Set ppt = GetObject(fname)
ppt.SaveAs ppt.FullName, ppSaveAsPNG ‘ppt.FullNameでファイル名のフォルダを作って、格納 ppt.FullNameの部分をパスを記載して出力先を固定にすることも可能 事前にフォルダの作成が不要（作成される）
ppt.Close
End If
Next
Set objFso = Nothing
‘スクリプトエラーでパワーポイントのプロセスが残った時の対策
objWshShell.Run “taskkill /im POWERPNT.EXE /F /T”, 7, False ‘ウィンドウを最小化ウィンドウとして表示アクティブなウィンドウは切り替わらない コマンドの終了を待たない
Set objWshShell = Nothing
Wscript.Echo “完了しました”