Batya
|
 Posted: Sat Feb 15, 2014 16:37 Post subject: |
 |
|
Нда... "Давно не брал я шашки в руки." (с) 
| Code: | '==========================================================================
' Печать нескольких документов с помощью MS Word
'
' Параметры:
' {Файл-список} [{Принтер} [{Кодовая страница} [{Количество копий} [{Номер(а) страниц}]]]]
' При пустом параметре (указывается "") используются значения по умолчанию
'
' Пример параметров при вызове из TC:
' %WL \\Host\HostPrinter 1251 "" "1"
'
' Автор - Batya
'==========================================================================
Option Explicit
Dim Docs
'================= Изменяемые параметры ===================================
Const TimeLimit = 30 'Время ожидания окончания печати в сек.
Const Margin = 1.5 'Поля в см
'Список расширений документов с наличием форматирования
Docs = Array("rtf","doc","docx")
'==========================================================================
Dim FSO, WSH, objW, Mess, ListF, List, Printer, CodePage, Copies, Pages, F
'Дюймы, выраженные в см., для вычисления полей
Const Inch = 2.538
SetMess
Set WSH = CreateObject("WScript.Shell")
Set FSO = CreateObject("Scripting.FileSystemObject")
'Включаем режим ручной обработки ошибок
On Error Resume Next
CheckParam :CheckErr 1,0
'Создаем объект Word
Set objW = CreateObject("Word.Application") :CheckErr 1,1
'Если задан принтер
If Printer <> "" Then objW.ActivePrinter = Printer :CheckErr 1,1 : WScript.Sleep 500
'Цикл по файлам
For Each F In List
If Trim(F) <> "" Then
F = GetPath(F)
'Обрабатываем только файлы
If FSO.FileExists(F) Then Print(F) :CheckErr 0,1
End If
Next
'Отключаем режим ручной обработки ошибок
On Error Goto 0
'Закрываем Word
objW.Quit 0
'Сообщение об окончании работы
MessBox Mess(99), 3
'Выход
Quit 0
'Открытие и печать документа
Sub Print(pFile)
Dim Doc, MarginPt, StartTime, WdPrintOutRange
'Открываем документ
Set Doc = objW.Documents.Open(pFile,False,True,False,,,,,,,CodePage)
'Задаем поля для документов без оформления
If InStr(1, "\" & Join(Docs, "\") & "\", "\" & FSO.GetExtensionName(pFile) & "\", 1) > 0 Then
'Поля в пунктах (1/72 дюйма)
MarginPt = Margin/Inch * 72
With Doc.PageSetup
.LeftMargin = MarginPt
.RightMargin = MarginPt
.TopMargin = MarginPt
.BottomMargin = MarginPt
End With
End If
If Pages <> "" Then
WdPrintOutRange = 4
Else
WdPrintOutRange = 0
End If
'Печатаем
objW.PrintOut True,,WdPrintOutRange,,,,,Copies,Pages
'Включаем таймер ожидания окончания печати
StartTime = Timer
'Ждем, пока закончится печать
Do Until objW.BackgroundPrintingStatus = 0
'Если ожидаем уже больше заданного лимита, выходим с ошибкой
If (Timer - StartTime) > TimeLimit Then Err.Raise vbObjectError + 4, Mess(0), Mess(4)
'Пауза 0.1 сек.
WScript.Sleep 100
Loop
'Закрываем документ
Doc.Close(False)
Set Doc = Nothing
End Sub
'Проверка параметров
Sub CheckParam
Dim lArg
Set lArg = WScript.Arguments
If lArg.Count = 0 Then Err.Raise vbObjectError + 1, Mess(0), Mess(1)
'Файл-список
ListF = GetPath(lArg(0))
If Not FSO.FileExists(ListF) Then Err.Raise vbObjectError + 2, Mess(0), Mess(2)
'Массив файлов\папок
List = Split(FSO.OpenTextFile(ListF, 1, False, -1).ReadAll, vbNewLine)
'Принтер
Printer = "" : If lArg.Count > 1 Then Printer = lArg(1)
'Кодовая страница
CodePage = "" : If lArg.Count > 2 Then CodePage = lArg(2)
'Количество копий
Copies = 1 : If lArg.Count > 3 Then Copies = lArg(3)
If Copies = "" Then Copies = 1
If Not IsNumeric(Copies) Then Err.Raise vbObjectError + 3, Mess(0), Mess(3)
'Номер(а) страниц
Pages = "" : If lArg.Count > 4 Then Pages = lArg(4)
End Sub
'Сообщение
Function MessBox(pMess, pMode)
Dim lIcon
Select Case pMode
Case 1 lIcon = vbCritical + vbOKOnly
Case 2 lIcon = vbExclamation + vbOKOnly
Case 3 lIcon = vbInformation + vbOKOnly
Case 4 lIcon = vbExclamation + vbOKCancel
End Select
MessBox = MsgBox(pMess, lIcon, Mess(0))
End Function
Function GetPath(pPath)
GetPath = FSO.GetAbsolutePathName(WSH.ExpandEnvironmentStrings(pPath))
End Function
'Проверка ошибок
Sub CheckErr(pMode1, pMode2)
Dim Flag
If Err.Number <> 0 Then
If pMode1 = 1 Then 'Безусловный выход
'Выводим сообщение
MessBox Mess(-1) & Err.Description, 1
Flag = vbOK
Else 'Выход по запросу
'Выводим сообщение
Flag = MessBox(Mess(-1) & Err.Description & Mess(-2), 4)
End If
If Flag = vbOK Then
If pMode2 = 1 Then
If IsObject(Doc) Then Doc.Close(False)
If IsObject(objW) Then objW.Quit
End If
Quit Err.Number
End If
End If
End Sub
'Задание массива сообщений
Sub SetMess
Set Mess = CreateObject("Scripting.Dictionary")
With Mess
.Add -1, "Возникла ошибка:" & vbNewLine & vbNewLine
.Add -2, vbNewLine & vbNewLine & "Прервать работу скрипта?"
.Add 0, "Печать документов"
.Add 1, "Не указаны входные параметры!"
.Add 2, "Файл-список не существует!"
.Add 3, "Указано некорректное количество копий!"
.Add 4, "Превышено время ожидания окончания печати."
.Add 99, "Операция завершена."
End With
End Sub
'Выход
Sub Quit(pQuitCode)
Set Mess = Nothing
Set objW = Nothing
Set WSH = Nothing
Set FSO = Nothing
WScript.Quit pQuitCode
End Sub
|
Тестировал не очень много - бумаги жалко. Так что, сильно не пинайте, если что
P.S. Скрипт получился не маленьким, т.к. приоритет отдаю читабельности кода, нежели компактности.
_________________
Нет, я не сплю. Я просто медленно моргаю. |
|
Rules
Search
FAQ
Memberlist
Usergroups
Register
Profile
Log in to check your private messages
Log in
