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

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

全シート左上選択（ウインドウ枠固定対応）

tmp = tmp & vbNewLine & "●全シート左上選択 "
tmp = tmp & vbNewLine & "（ウインドウ枠固定対応） "
tmp = tmp & vbNewLine & " "
tmp = tmp & vbNewLine & "　ドロップしたエクセルの "
tmp = tmp & vbNewLine & "　全てのシートの左上を選択状態にします。"
tmp = tmp & vbNewLine & "　ウインドウ枠の固定がされている場合は　"
tmp = tmp & vbNewLine & "　枠の左上隅を選択状態にします。　　　　"
tmp = tmp & vbNewLine & "　その後、最初のシートを選択状態にして "
tmp = tmp & vbNewLine & "　上書き保存します。 "
tmp = tmp & vbNewLine & " "
tmp = tmp & vbNewLine & "----------------------------------------"
tmp = tmp & vbNewLine & "操作方法 "
tmp = tmp & vbNewLine & " エクセルファイルをこのVBSに "
tmp = tmp & vbNewLine & " ドラッグ＆ドロップしてください "
tmp = tmp & vbNewLine & " 複数ファイルもドロップ可能 "
tmp = tmp & vbNewLine & " "
tmp = tmp & vbNewLine & "出力先 "
tmp = tmp & vbNewLine & " 強制的に上書きします。 "
tmp = tmp & vbNewLine & " "
tmp = tmp & vbNewLine & "補足 "
tmp = tmp & vbNewLine & "×実行できません。引数一覧が長すぎます。"
tmp = tmp & vbNewLine & "が表示された場合はドロップしたファイルが"
tmp = tmp & vbNewLine & "多すぎる時です "

If ( WScript.Arguments.Count = 0 ) Then
WScript.Echo tmp
WScript.Quit
End If

Dim fName
Dim xlApp
Dim xlWb

Set xlApp = WScript.CreateObject("Excel.Application")
For Each fName in WScript.Arguments
Set xlWb = xlApp.Workbooks.Open(fName)
For Each xlSht in xlWb.WorkSheets
xlSht.Activate
If xlApp.ActiveWindow.FreezePanes = False Then
xlSht.Range("A1").Activate
Else
xlSht.Cells(xlApp.ActiveWindow.SplitRow+1,xlApp.ActiveWindow.SplitColumn+1).Activate
End If
Next
xlWb.Worksheets(1).Activate
xlWb.Save
xlWb.Close False
Next
xlApp.Quit
Set xlApp = Nothing
WScript.Echo "実行完了"

ドロップしたエクセルをブック印刷する

tmp = tmp & vbNewLine & "----------------------------------------"
tmp = tmp & vbNewLine & " "
tmp = tmp & vbNewLine & "●ドロップしたエクセルをブック印刷する "
tmp = tmp & vbNewLine & " 　非表示シート対応版 "
tmp = tmp & vbNewLine & " "
tmp = tmp & vbNewLine & "----------------------------------------"
tmp = tmp & vbNewLine & " "
tmp = tmp & vbNewLine & "操作方法 "
tmp = tmp & vbNewLine & " エクセルファイルをこのVBSに "
tmp = tmp & vbNewLine & " ドラッグ＆ドロップする。 "
tmp = tmp & vbNewLine & " 複数ファイルもドロップ可能 "
tmp = tmp & vbNewLine & " "
tmp = tmp & vbNewLine & "出力先 "
tmp = tmp & vbNewLine & " 標準のプリンタに出力します "
tmp = tmp & vbNewLine & " "

If ( WScript.Arguments.Count = 0 ) Then
WScript.Echo tmp
WScript.Quit
End If

Dim fName
Dim xlApp
Dim xlWb

Set xlApp = WScript.CreateObject("Excel.Application")
For Each fName in WScript.Arguments
Set xlWb = xlApp.Workbooks.Open(fName)
xlApp.ExecuteExcel4Macro "PRINT(1,,,1,,,,,,,,3,,,TRUE,,FALSE)"
xlWb.Close False
Next
xlApp.Quit
Set xlApp = Nothing

全てのシートの表示を100%にする

'----------------------------------------
' xls100perAllSheetA1.vbs
'
'ドロップしたエクセルの
' 全てのシートの表示を100%にする
' その後、最初のシートを選択状態にして
' 上書き保存します。
'
'----------------------------------------
' 操作方法
' エクセルファイルをドラッグ＆ドロップするだけ
' 複数ファイルもドロップ可能
'
' 出力先
' 強制的に上書きします。
'
Dim fName
Dim xlApp
Dim xlWb

Set xlApp = WScript.CreateObject("Excel.Application")
For Each fName in WScript.Arguments
Set xlWb = xlApp.Workbooks.Open(fName)
For Each xlSht in xlWb.WorkSheets
xlSht.Activate
xlApp.ActiveWindow.Zoom=100
Next
xlWb.Worksheets(1).Activate
xlWb.Save
Next
xlApp.Quit
Set xlApp = Nothing

全てのシートの左上を選択状態に

'----------------------------------------
' xlsSelectAllSheetA1.vbs
'
'ドロップしたエクセルの
' 全てのシートの左上を選択状態にした後
' 最初のシートを選択状態にして
' 上書き保存します。
'
'----------------------------------------
' 操作方法
' エクセルファイルをドラッグ＆ドロップするだけ
' 複数ファイルもドロップ可能
'
' 出力先
' 強制的に上書きします。
'
Dim fName
Dim xlApp
Dim xlWb

Set xlApp = WScript.CreateObject("Excel.Application")
For Each fName in WScript.Arguments
Set xlWb = xlApp.Workbooks.Open(fName)
For Each xlSht in xlWb.WorkSheets
xlSht.Activate
xlSht.Range("A1").Activate
Next
xlWb.Worksheets(1).Activate
xlWb.Save
Next
xlApp.Quit
Set xlApp = Nothing