nabezo wiki

Excelの印刷ツールです。 インストール方法 †

実行すると、右クリック時の送るに自分自身のショートカットを作成します。 ↑ 使い方 †

印刷したいExcelファイルを選択し、右クリックの送るでスクリプトを起動する そうすると、すべてのシートの内容を印刷する。 （複数ファイル対応） ↑ プログラム †

'-------------------------------
'右クリックでEXCEL印刷プログラム
'2007/04/20 ver 1.0
'2008/07/11 ver 1.1 sort追加
'-------------------------------
Option Explicit
Const CNS_DSPLOG = True		'ログ表示
Const CNS_DEBUGLOG = False	'デバッグログ表示
Const cnsVer = "Ver1.1"
Call Main()

WScript.Quit(0)

'-------------------------------
'メイン
'-------------------------------
Sub Main()
	Dim objFS
	Dim objArgs
	Dim idx
	Dim strFName
	Dim strMsg
	Dim ret

	Set objArgs = WScript.Arguments
	Set objFS = CreateObject("Scripting.FileSystemObject")

	If objArgs.Count = 0 Then
		'パラメータ無しなら「右クリック送る」に自分自身をコピーする。
		Call CopySendTo()
	Else
		'実行確認
		strMsg = ""

		'パラメータから配列に
		ReDim aryArg( objArgs.Count - 1 )
		For idx = 0 to  objArgs.Count - 1
			aryArg(idx) = objArgs(idx)
		Next
		'ファイル名順にソート
		Call SortAry(aryArg)
		
		'ファイル名確認メッセージボックス
		For idx = 0 to  Ubound(aryArg)
			strFName = aryArg(idx)
			strMsg = strMsg & strFName & vbCrLf
		Next 
		strMsg = strMsg & "印刷します。　よろしいですか？"
		ret = MsgBox( strMsg , vbOkCancel + vbDefaultButton1, WScript.ScriptName & " " & cnsVer)

		'OKなら印刷
		If ret = vbOk Then
			'印刷する
			For idx = 0 to Ubound(aryArg)
				strFName = aryArg(idx)
				Call DebugLog( strFName )
				If objFs.FileExists(strFName) = True Then
					If UCase( objFS.GetExtensionName(strFName) ) = "XLS" Then 
						'XLSファイルが存在するならExcel印刷
						Call ExcelPrint(strFName)
					Else
						Call Msgbox(strFName & vbCrLf & "エクセルファイルではありません",, WScript.ScriptName & " " & cnsVer)
					End If
				End If
			Next 
			Call MsgBox("印刷が完了しました。",,WScript.ScriptName & " " & cnsVer)
		End If
	End If

	Set objFS = Nothing 
	Set objArgs = Nothing 
End Sub

'/////////////////////////////////////////////////
'その他サブルーチン
'/////////////////////////////////////////////////
'シートの印刷
Sub ExcelPrint(FNAME)
	Dim wBook, wSheet
	Call DebugLog( FNAME )
	Set wBook = GetObject(FNAME)
	'--wBook.Application.Visible = True
	'--wBook.Activate
		
	'--マクロの動作をさせない
	'--WScript.Shell.Sleep 2000
	'--WScript.Shell.SendKeys "{SPACE}"
	
	'--AcitveSheetの印刷
	'--Set wSheet = wBook.ActiveSheet
	'--wSheet.PrintOut
	
	'--ブックのすべてを印刷する
	wBook.Worksheets.PrintOut		'ブックのすべてを印刷する
	WScript.Sleep(500)
	wBook.Close(False)	'Not Save Change
	WScript.Sleep(500)
	Set wBook=Nothing
End Sub

Sub CopySendTo()
	'パラメータ無しで実行した場合はSendToに自分自信を作成する。
	Dim objWshShell, objFS
	Set objWshShell = CreateObject("WScript.Shell")
	Set objFS = CreateObject("Scripting.FileSystemObject")
	objFS.CopyFile WScript.ScriptFullName , objWshShell.SpecialFolders("SendTo") & "\" & WScript.ScriptName
	Call MsgBox("右クリック-「送る」に " & WScript.ScriptName & " をコピーしました。",,WScript.ScriptName & " " & cnsVer)
	Set objWshShell = Nothing 
	Set objFS = Nothing 
End Sub

Sub PutLog(Msg)
	Dim strMsg
	strMsg = Now & vbTab & Msg
	If CNS_DSPLOG = True Then
		Wscript.Echo(strMsg)
	End if 
End Sub

Sub DebugLog(Msg)
	If CNS_DEBUGLOG = True Then
		Call PutLog(Msg)
	End if 
End Sub

'/////////////////////////////////////////////////
'配列のソート
'/////////////////////////////////////////////////
Sub SortAry(aryWk)
	Dim strWork
	Dim idx,idy,idz
	For idx = 0 to Ubound(aryWk)
		idz = idx
		strWork = aryWk(idx)
		For idy = idx + 1 to  Ubound(aryWk)
			If aryWk(idy) < strWork Then
				strWork = aryWk(idy)
				idz = idy
			End If
		Next
		aryWk(idz) = aryWk(idx)
		aryWk(idx) = strWork
	Next
End Sub