ドロップしたファイルかフォルダで全てのエクセルをブック印刷

t=t&"ドラッグ＆ドロップでエクセルをブック印刷する　　" & vbNewLine
t=t&"------------------------------------------------" & vbNewLine
t=t&"フォルダ内にあるエクセルをサブフォルダを含めて " & vbNewLine
t=t&"全てブック印刷します。　　　　　　 　　　　　　 " & vbNewLine
t=t&"標準のプリンタに印刷します　　 　　　　　　　　 " & vbNewLine
t=t&"　　　　　　　　　　　　　　　　　　　　　　　　" & vbNewLine
t=t&" 2014/3/10 Ver1.0 　　　 　　　　　　　　　　　 " & vbNewLine
t=t&" 　　　　　　　　　　　　　　　　　　　　　　　 " & vbNewLine

TargetExt="xls"
PQ=300 '印刷品質　プリンタに合わせて変更が必要

'------------------------------
' ファイルの実行
'------------------------------
Sub Execfile(File)
Set xlWb = xlApp.Workbooks.Open(File)
' For Each xlSht in xlWb.WorkSheets
' xlSht.PageSetup.PrintQuality=PQ
' Next
xlWb.Printout,,1 ' １部
xlWb.Close False

End Sub


'---------------------------------------
'プログラム自体はここからスタート
'---------------------------------------
If WScript.Arguments.Count > 0 Then

Set objShell = WScript.CreateObject("WScript.Shell")
If objShell.Popup("３秒後に自動的に実行します",3,WScript.ScriptName,1)<>2 Then

Set xlApp = WScript.CreateObject("Excel.Application")
xlApp.Visible = False
xlApp.ScreenUpdating = False
xlApp.DisplayAlerts = False
' xlApp.Options.UpdateLinksAtOpen = False
Set objFS = CreateObject("Scripting.FileSystemObject")


For Each PathName in WScript.Arguments
Call Main(PathName)
Next
'If pExec.Status=0 Then pExec.Terminate
call objShell.Popup(WScript.ScriptName & vbNewLine & "【実行完了】" & vbNewLine & vbNewLine & "30秒後に自動的に閉じます",30)
' xlApp.Quit
Set xlApp = Nothing
Set objFS = Nothing
Else
call objShell.Popup("実行せずに終了しました" & vbNewLine & vbNewLine & "30秒後に自動的に閉じます",30)
End If

Else
WScript.Echo t
End If

' xlApp.Quit
' Set xlApp = Nothing
' Set objFS = Nothing

WScript.Quit

'---------------------------------------

Sub Main(ByVal objPath)
' Dim objFS,objFolder
Dim objFolder

' Set objFS = CreateObject("Scripting.FileSystemObject")
If objFS.FolderExists(objPath) Then
Set objFolder = objFS.GetFolder(objPath)
Call PathAll(objFolder)
ElseIf objFS.FileExists(objPath) Then
Call OneFile(objPath)
End If
' Set objFS = Nothing

End Sub
'------------------------------------------------
' ファイルならファイル処理。フォルダなら再帰処理
'------------------------------------------------
Sub PathAll(ByVal objFolder)
Dim objFile,files
Set files = objFolder.Files
For Each objFile In files
Call OneFile(objFile.Path)
Next
Dim subfolders,objSub
Set subfolders = objFolder.SubFolders
For Each objSub In subfolders
Call PathAll(objSub)
Next
End Sub
'------------------------------------------------
' 指定拡張子のファイルのみを抽出
'------------------------------------------------
Sub OneFile(ByVal file)
ext = objFS.GetExtensionName(file)
If ext = TargetExt Then
Execfile(file)
End If
End Sub