Тема: HTA: нанесение (расстановка) OMR-меток в файле MS Word
"А не замахнуться ли нам на ВильЯма нашего, так сказать, Шекспира?" (цитата из фильма, может и не точная).
Немного предыстории.
В конторе куча корреспонденции, для её упаковки приобретена конвертовальная машина. Ежели бы в каждый конверт ложилось фиксированное количество листов, то вопрос бы не возник… Машина умеет читать OMR-метки. Проблема в том, как их нанести.
Поясню. OMR-метки (Optical mark recognition) — это штрихи на полях. В моём случае 2 штриха на 1-й странице и 4 штриха на последней (или единственной). Наверное, видали такие на документах, положим, из банка или счетах каких-нибудь. В общем, возникла у меня мысль написать скрипт для проставления сиих меток.Файл представляет собой документ в формате Microsoft Word (.rtf или .doc), созданный программой, которая формирует уведомления о платежах и квитанции, и которая не умеет, а, по словам разработчиков, и не будет уметь, наносить OMR-метки.
Нужно пробежаться по нему 2 раза:
1. Поиск уникальной фразы, которая присутствует только на первом (или единственном) листе вложения (типа "Адрес получателя") и запоминание массива страниц с этой фразой.
2. Расставление меток. Внесение в документ на поля элемента типа «Надпись», в котором содержится штрих.Предположим, выгрузилось 100 уведомлений, у 10 нет квитанций (всё оплачено), у 50 есть квитанция на одном листе, у 40 есть квитанция на 2 листах. Всего получилось 10*1 + 50*2 + 40*3 = 230 страниц. Все уведомления идут по порядку, т.е. уведомление + квитанция … квитанция, уведомление, уведомление + квитанция и т.д. На странице с уведомлением есть уникальная фраза «время работы», на квитанциях её нет.
Алгоритм расстановки следующий.
Если (страница последняя) или (на следующей странице есть фраза) То
Ставь 4 полоски
Иначе
Ставь 2 полоски
Конец ЕслиМашина делает следующее.
Берёт лист, "смотрит" метку.
Если 2 полоски, то следующую.
Если 4, то запечатывает весь набор в конверт.Это наипростейший пример реализации OMR.
OMR 1.3
<html id="appHTML">
<head>
<meta charset="windows-1251">
<meta http-equiv="Content-Type" content="text/html; charset=windows-1251">
<meta http-equiv="Content-Language" content="ru">
<title>OMR-метки.</title>
<hta:Application
Icon = ""
Id="oHTA"
ApplicationName="OMR"
Border="Dialog"
BorderStyle="Raised"
Caption="yes"
ContextMenu="no"
InnerBorder="yes"
MaximizeButton="no"
MinimizeButton="yes"
Navigable="no"
Scroll="no"
ScrollFlat="no"
Selection="yes"
ShowInTaskbar="yes"
SingleInstance="yes"
SysMenu="yes"
Version="1.3"
WindowState="normal"
/>
<style type="text/css">
.h2 {
color:#000000;
font: 17px; "Trebuchet MS", Verdana, Arial, Helvetica, sans-serif;
}
.readonly {
background-color : #afb0b0;
color : #000000;
font: 15px; "Trebuchet MS", Verdana, Arial, Helvetica, sans-serif;
border: none;
}
.Capts {
background-color : #afb0b0;
color : #000000;
font: 11px; "Trebuchet MS", Verdana, Arial, Helvetica, sans-serif;
border: none;
}
.copyright {
color: #201868;
font: normal 11px Verdana, Arial, Helvetica, sans-serif;
}
a.copyright {
color: #02036A;
text-decoration: none;
}
a.copyright:hover {
color: #000000;
text-decoration: underline;
}
input {
color : #02036A;
font: normal 11px Verdana, Arial, Helvetica, sans-serif;
padding: 0px 5px;
}
input.mainoption {
background-color : #D4DB09;
border-color : #0E0889;
font-weight : bold;
}
</style>
<script language="VBScript">
'Что ж, будем объявлять переменные...
Option Explicit
'----------------------------------------------------------------------
Sub SetWindowPosition(intWindowWidth, intWindowHeight)
'Позиционирование и изменение размера окна
With window
.resizeTo intWindowWidth, intWindowHeight
.moveTo (.screen.availWidth - intWindowWidth) \ 2, (.screen.availHeight - intWindowHeight) \ 2
End With
End Sub
'----------------------------------------------------------------------
Sub SelFile_OnChange
'Проверка выбранного файла
If LCase(Right(SelFile.Value, 4)) <> ".doc" And LCase(Right(SelFile.Value, 4)) <> ".rtf" Then
MsgBox "Выбран неверный файл"
SelFile.Value =""
End If
End Sub
'----------------------------------------------------------------------
Sub SetOMR_OnClick
'Расстановка меток
'Константы
Const wdActiveEndPageNumber = 3 'Константа из WdInformation
Const wdCollapseStart = 1 'Константа из WdCollapseDirection
Const wdGoToAbsolute = 1 'Константа из WdGoToDirection
Const wdGoToPage = 1 'Константа из WdGoToDirection
Const msoTextOrientationHorizontal = 1 'Горизонтальная ориентация текста
Const TextBoxLeft = 0 'Надпись. Отступ слева.
Const TextBoxTop = 214 'Надпись. Отступ сверху
Const TextBoxWidth = 40 'Надпись. Ширина.
Const TextBoxHeight = 45 'Надпись. Высота
'Переменные
Dim objWord 'Объект Microsoft Word
Dim PageDictTemp 'Временный словарь страниц с метками
Dim PageDict 'Перенумерованный словарь
Dim FindText 'Фраза для поиска
Dim objWMIService 'Обьект WMI
Dim colInstalledPrinters 'Колекция установленных принтеров
Dim objPrinter 'Принтер в коллекции
Dim ReadyToPrint 'Отправить на печать. Булево.
Dim PrintStatus 'Текст для сообщения. Связан с ReadyToPrint.
Dim StartTime 'Время начала операции расстановки меток.
Dim PageCount 'Количество страниц в документе
Dim ArrItems 'Массив элементов словаря PageDict
Dim FileNameWithOMR 'Имя файла для сохранения
Dim TextBox1 'Надпись с метками
Dim i 'Счётчик
'Проверка на наличие фразы
If FindTextField.Value = "" Then
MsgBox "Нужна фраза для поиска"
Exit Sub
End If
'Проверка на наличие файла
If SelFile.Value = "" Then
MsgBox "Файл не выбран"
Exit Sub
End If
'Проверки пройдены. Создание объектов.
Set objWord = CreateObject("Word.Application")
Set PageDictTemp = CreateObject("Scripting.Dictionary")
Set PageDict = CreateObject("Scripting.Dictionary")
FindText = FindTextField.Value
'Имя принтера по умолчанию
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
Set colInstalledPrinters = objWMIService.ExecQuery ("Select * from Win32_Printer Where Default = True")
For Each objPrinter In colInstalledPrinters
'Будет ли отправлено на печать
Select Case MsgBox ("Принтер по умолчанию : " & objPrinter.DeviceID & VbCrLf & "Распечатать файл после обработки?" & VbCrLf & "(Убедитесь, что принтер включен)", vbYesNo+vbQuestion+vbSystemModal, "Печать")
Case vbYes : ReadyToPrint = True
End Select
Next
PrintStatus = "На печать не отправлено"
'Время начала работы
StartTime = Time
With objWord
'Открытие документа
.Documents.Open(SelFile.Value)
'Количество страниц
PageCount = .ActiveDocument.ActiveWindow.Panes(1).Pages.Count
With .Selection
While .Find.Execute(FindText)
'Формирование временного массива страниц с найденой фразой
PageDictTemp.Add .Information(wdActiveEndPageNumber), ""
Wend
End With
'Перенумерация
For i = 1 To PageCount
If PageDictTemp.Exists(i) Then
PageDict.Add i, i
Else
PageDict.Add i, 0
End If
Next
PageDict.Add PageCount + 1, PageCount + 1
ArrItems = PageDict.Items
'отключение проверки орфографии и пунктуации
With .Options
.CheckSpellingAsYouType = False
.CheckGrammarAsYouType = False
End With
With .ActiveDocument
.ShowGrammaticalErrors = False
.ShowSpellingErrors = False
End With
'"Замораживание"
.Application.ScreenUpdating = False
.System.Cursor = 0
'Перебор по всем страницам
For i = 1 To PageCount
With .Selection
'"Сброс" выделения и переход на страницу i
.Collapse wdCollapseStart
.GoTo wdGoToAbsolute, wdGoToPage, i
End With
'Создание надписи
Set Textbox1 = .ActiveDocument.Shapes.AddTextbox (msoTextOrientationHorizontal, TextBoxLeft, TextBoxTop, TextBoxWidth, TextBoxHeight)
With Textbox1
'Установка размера шрифта и прозрачности
.TextFrame.TextRange.Font.Size = 16
.Line.Transparency = 1
.Fill.Transparency = 1
End With
With .Selection
'Нанесение меток.
'Если (Страница не последняя) И (На следующей странице нет фразы) То
' Наносим 2 линии
'Иначе
' Наносим 4 линии
'Конец Если
If (i < PageCount) And (ArrItems(i) = 0) Then
Textbox1.TextFrame.TextRange.Select
.InsertSymbol &H2500, "Times New Roman", True
.InsertSymbol &H2500, "Times New Roman", True
.TypeParagraph
.TypeParagraph
.TypeParagraph
.InsertSymbol &H2500, "Times New Roman", True
.InsertSymbol &H2500, "Times New Roman", True
Textbox1.TextFrame.TextRange.Select
Else
Textbox1.TextFrame.TextRange.Select
.InsertSymbol &H2500, "Times New Roman", True
.InsertSymbol &H2500, "Times New Roman", True
.TypeParagraph
.InsertSymbol &H2500, "Times New Roman", True
.InsertSymbol &H2500, "Times New Roman", True
.TypeParagraph
.InsertSymbol &H2500, "Times New Roman", True
.InsertSymbol &H2500, "Times New Roman", True
.TypeParagraph
.InsertSymbol &H2500, "Times New Roman", True
.InsertSymbol &H2500, "Times New Roman", True
Textbox1.TextFrame.TextRange.Select
End If
'Форматируем надпись
With .ParagraphFormat
.LineSpacingRule = 5
.LineSpacing = objWord.LinesToPoints(0.58)
End With
End With
Next
'"Размораживаем"
.System.Cursor = 2
.ScreenUpdating = True
'Проверка, отправлять ли на печать
If ReadyToPrint Then
PrintStatus = "Отправлено на печать"
.PrintOut
End If
'Формирование нового имени
FileNameWithOMR = Left(SelFile.Value, Len(SelFile.Value) - 4) & "_OMR" & Right(SelFile.Value, 4)
'Сохранение под новым именем и закрытие
.ActiveDocument.SaveAs FileNameWithOMR
.ActiveDocument.Close
End With
'Закрытие объекта
objWord.Quit
Set objWord = Nothing
'Вывод собщения
MsgBox "На обработку затрачено " & Int(DateDiff("s", StartTime, Time)\60) & " мин. " & DateDiff("s", StartTime, Time) - Int(DateDiff("s", StartTime, Time)\60) * 60 & " сек." & vbCrLf & "Файл сохранён как " & FileNameWithOMR & vbCrLf & PrintStatus, vbSystemModal, "Метки расставлены"
End Sub
'----------------------------------------------------------------------
</script>
</head>
<body id="tagBody" bgcolor="#afb0b0" background="" scroll="no" onload="SetWindowPosition 800, 230">
<div align="center">
<table border="1" bgcolor="black" width="100%">
<tr>
<td width="100%" bgcolor="f8f9d4">
<div align="center">
<span class="h2">Здесь может быть ваша реклама
</span><br>
</div>
</td>
</tr>
</table>
<br>
</div>
<table align = center>
<tr>
<td>
1) Выберите файл .rtf или .doc (кнопка "Обзор...")
<td>
<td align = center>
<input type="File" size = 20 name="SelFile" Class = ReadOnly>
<td>
</tr>
<tr>
<td>
2) Введите уникальную фразу
<td>
<td align = center>
<input type="Text" Value="уникальная фраза" size = 25 name = "FindTextField">
<td>
</tr>
<tr>
<td>
3) Нажмите кнопку "Расставить метки"
<td>
<td align = center>
<input type="Button" Value="Расставить метки" name="SetOMR">
<td>
</tr>
</table>
</body>
</html>
Автор скрипта — MikeSh.