'==========================================================================
'Печать документа с помощью MS Word
'Параметры:
'{Файл} [{Принтер}|"" [{Кодовая страница}|"" [{Количество копий}]]]
'Пример параметров:
'C:\Temp\Test.txt \\Host\HostPrinter 1251
'Для использования значений по умолчанию принтера или кодовой страницы
' можно указать двойные кавычки ("")
'Пример параметров:
'C:\Temp\Text_default.txt
'C:\Temp\Text_dos.txt "" 866
'C:\Temp\Text_3_copies.txt "" "" 3
'==========================================================================
Option Explicit
'================= Изменяемые параметры ===================================
Const TimeLimit = 30 'Время ожидания окончания печати в сек.
Const Margin = 1.5 'Поля в см
Const Admin = "admin" 'Имя компьютера сис. админ-а
Const ShowMess = False 'Показывать ли текст ошибки на текущем компе
'==========================================================================
Dim objW, Mess, MarginPt, File, Ext, StartTime, CodeStr, Copies
'Дюймы, выраженные в см., для вычисления полей
Const Inch = 2.538
'Задаем массив сообщений
DefineMess
'Включаем режим ручной обработки ошибок
On Error Resume Next
'Создаем объект Word
Set objW = WScript.CreateObject("Word.Application")
CheckErr(0)
'Первый параметр - открываемый файл
File = WScript.Arguments(0)
CheckErr(1)
'Открываем файл в кодировке, заданной третим параметром
If WScript.Arguments.Count > 2 Then
CodeStr = WScript.Arguments(2)
If Len(CodeStr) <> 0 Then
objW.Documents.Open File,,1,,,,,,,,CodeStr
Else
objW.Documents.Open File,,1
End If
Else
objW.Documents.Open File,,1
End If
CheckErr(1)
'Вычисляем поля (задаются в пунктах - 1/72 дюйма)
MarginPt = Margin/Inch * 72
'Задаем поля для всех файлов, кроме *.doc и *.rtf
Ext = LCase(CreateObject("Scripting.FileSystemObject").GetExtensionName(File))
If Not ((Ext = "doc") Or (Ext = "rtf")) Then
With objW.ActiveDocument.PageSetup
.LeftMargin = MarginPt
.RightMargin = MarginPt
.TopMargin = MarginPt
.BottomMargin = MarginPt
End With
CheckErr(2)
End If
'Если задан второй параметр, то это принтер
If WScript.Arguments.Count > 1 Then
'Устанавливаем принтер, если параметр не пустой
If Len(WScript.Arguments(1)) > 0 Then
'Устанавливаем текущий принтер - второй параметр
objW.ActivePrinter = WScript.Arguments(1)
'Небольшая пауза
WScript.Sleep 100
CheckErr(3)
End If
End If
'Количество копий
If WScript.Arguments.Count > 3 Then
Copies = WScript.Arguments(3)
Else
Copies = 1
End If
'Печатаем в фоне
objW.PrintOut 1,,,,,,,Copies
CheckErr(4)
'Включаем таймер ожидания окончания печати
StartTime = Timer
'Ждем, пока закончится печать
Do Until objW.BackgroundPrintingStatus = 0
'Если ожидаем уже больше заданного лимита
If (Timer - StartTime) > TimeLimit Then
'Генерим ошибку
Err.Raise vbObjectError + 1, Mess("Title"), Mess("Err1")
CheckErr(5)
End If
'Пауза 0.1 сек.
WScript.Sleep 100
Loop
'Закрываем Word
objW.Quit 0
CheckErr(6)
'Отключаем режим ручной обработки ошибок
On Error Goto 0
'Выход
Quit
'Процедура задания массива сообщений
Sub DefineMess
Set Mess = CreateObject("Scripting.Dictionary")
With Mess
.Add "Title", "Печать документа"
.Add "Err1" , "Время ожидания окончания печати превысило заданный лимит. Печать прервана!"
.Add 0 , "При создании объекта Word возникла ошибка:"
.Add 1 , "Ошибка открытия файла:"
.Add 2 , "Ошибка задания полей:"
.Add 3 , "При установке активного принтера возникла ошибка:"
.Add 4 , "При выполнении печати документа возникла ошибка:"
.Add 5 , "Ошибка выполнения печати."
.Add 6 , "Ошибка закрытия документа. Закройте документ вручную."
End With
End Sub
'Процедура проверки ошибок
Sub CheckErr(Step)
'Если произошла ошибка
If Err.Number <> 0 Then
'Посылаем сообщение на компьютер Admin
CreateObject("WScript.Shell").Run "net send " & Admin & " " &_
Mess(Step) & vbNewLine & vbNewLine & Err.Description, 7, False
'Выводим сообщение на текущем компьютере
If ShowMess Then
MsgBox Mess(Step) & vbNewLine & vbNewLine & Err.Description, _
vbOKOnly + vbCritical, Mess("Title")
End If
'Закрываем Word, если открыт
If (Step > 0) And IsObject(objW) Then
objW.Quit 0
End If
Quit
End If
End Sub
Sub Quit
Set Mess = Nothing
Set objW = Nothing
WScript.Quit
End Sub