エクセルファイルを選択して開くダイアログボックスを実行するvbsファイルのフォルダをデフォルトにする
注意　以下をコピーする時は、 ’と〝　”　を半角の　’ と　”に置き換える必要がある

Dim xlsApp
Dim DPath
Dim FilePath
Dim objShell

‘カレントディレクトリを取得
Set objShell = CreateObject(“WScript.Shell”)
currentDir = objShell.CurrentDirectory

‘.DefaultFilePathにカレントディレクトリをセット
Set xlsApp = CreateObject(“Excel.Application”)
DPath= xlsApp.DefaultFilePath
With xlsApp
.DefaultFilePath = currentDir
.Quit
End With
Set xlsApp = Nothing ‘一度開放して設定を反映
Set xlsApp = CreateObject(“Excel.Application”)

‘カレントディレクトリを初期フォルダでダイアログが開く
FilePath= xlsApp.GetOpenFilename(“Excel File,*.xlsx;*.xls,All,*.*”,1,”ファイルを選択して下さい”,”開く”,false)
If FilePath <> False Then
‘Wscript.Echo FilePath ‘確認時に使用
Else
WScript.Quit ‘キャンセルしてファイルを選択しなかった時
End If

‘FilePathを使って以下に実際の処理を記述

画面をスクロールさせるのに、CTRL+ENDやCTRL+HOMEを使っているが、ツールボタンに追加して、クリックするだけで移動できるようにする
ツールバーアドオンに追加で実行を設定する

タイプをVBScriptでオプションに以下を記述
Set WshShell = CreateObject(“WScript.Shell”)
WshShell.SendKeys (“^{END}”)

Set WshShell = CreateObject(“WScript.Shell”)
WshShell.SendKeys (“^{HOME}”)

または、タイプを実行で

Tablacus ExplorerフォルダへVBSファイルの格納してこれを実行

VBSのキー・ストローク送信を実行する
※下記のコードコピーする時は”を半角に変更すること
＜end.vbs＞
Set objShell = WScript.CreateObject(“WScript.Shell”)
objShell.SendKeys “^{END}”

＜home.vbs＞
Set objShell = WScript.CreateObject(“WScript.Shell”)
objShell.SendKeys “^{HOME}”

注意　このブログは、’と“”が全角に置き換わるので、vbsファイルへコピー後に、半角のシングルクォーテーションと半角のダブルクォーテーションに置き換えること
※ “と”をダブルクォーテーションに置き換える

Option Explicit
‘************************
‘カレントディレクトリのファイル名の半角をアンダーバーに置き換える

Dim after

Dim objFolder
Dim objFile
Dim objFileSys
Dim strExtension
Dim myPath
Dim objShell

Set objShell = CreateObject( “WScript.Shell” )
myPath = objShell.CurrentDirectory ‘myPathをカレントディレクトリ指定 ここを変更すると任意のディレクトリにも出来る
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 <> “” Then ‘＜＞””は未指定、=”pptx”等で拡張子を指定できる

If InStr(objFile.Name,” “) Then ‘空白を含む場合のみ処理
after = Replace(objFile.Name,” “,”_”)
‘ファイル名変更
objFile.Name = after
End If

If InStr(objFile.Name,”　”) Then ‘全角の空白も処理にしている 不要ならコメントアウト
after = Replace(objFile.Name,”　”,”_”)
‘ファイル名変更
objFile.Name = after
End If

End If

Next

Set objFile = Nothing
Set objFileSys = Nothing
Set objFolder = Nothing

Wscript.Echo “完了しました” ‘不要ならコメントアウト

スクリプトを実行したフォルダ内の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 “完了しました”