* окно HTA использует стандартные цвета установленной цветовой схемы: для фона — фон окна диалога («background-color: ButtonFace»), для текста — цвет переднего плана окна («color: WindowText»).
* для формирования нового имени документа используется компонент «Scripting.FileSystemObject».
+ теперь, чтобы переключить флажок печати содержимого документа после обработки, можно щёлкать и по имени принтера.
+ для информирования о завершении обработки используется мигание фоном окна («.backgroundColor = "ActiveCaption"/"InactiveCaption"» в процедуре «FlashBody») и звуковой сигнал («bgsound id="Sound"…») на основе VBScript: воспроизведение аудио. Мигание и звуковой сигнал останавливаваются при движении мышки над рабочим пространством окна приложения (процедура «FlashBodyStop»). Поддерживаются стандартные форматы *.wav и *.mid.
<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-меток в файле MS Word</title>
<hta:Application
Icon = "%ProgramFiles%\Microsoft Office\OFFICE11\WINWORD.EXE"
Id="oHTA"
ApplicationName="Нанесение (расстановка) OMR-меток в файле MS Word"
Border="normal"
BorderStyle="normal"
Caption="yes"
ContextMenu="no"
InnerBorder="yes"
MaximizeButton="no"
MinimizeButton="yes"
Navigable="no"
Scroll="auto"
ScrollFlat="no"
Selection="no"
ShowInTaskbar="yes"
SingleInstance="yes"
SysMenu="yes"
Version="1.5 RC1"
WindowState="normal"
/>
<bgsound id="Sound" Loop="1" src="">
<style type="text/css">
BODY {
font: x-small Verdana, Arial, sans-serif;
color: WindowText;
background-color: ButtonFace;
}
.Row{
clear:both;
}
.Left{
float:Left;
clear:none;
}
.Right{
float:Right;
clear:none;
}
.NonValid { color:FireBrick; }
#Status { font: xx-small; }
</style>
<script language="VBScript">
Option Explicit
'----------------------------------------------------------------------
Sub SetOMR_OnClick
' Если введённые данные корректны…
If ValidateFields() Then
With document
.getElementByID("Status").innerText = "Идёт обработка…"
.getElementByID("SelFile").disabled = True
.getElementByID("FindTextField").disabled = True
.getElementByID("PrintAfterProcessing").disabled = True
.getElementByID("SetOMR").disabled = True
.getElementByID("tagBody").style.cursor = "wait"
End With
' Опосредованно вызываем основную процедуру обработки документа
setTimeout "SetOMR", 0
End If
End Sub
'----------------------------------------------------------------------
'----------------------------------------------------------------------
Sub SetOMR_OnBlur()
' При потере фокуса элементом SetOMR очистить строку статуса
' и стили элементов управления
With document
.getElementByID("Status").innerText = ""
.getElementByID("lblSelFile").className = ""
.getElementByID("SelFile").className = ""
.getElementByID("lblFindTextField").className = ""
.getElementByID("FindTextField").className = ""
End With
End Sub
'----------------------------------------------------------------------
'----------------------------------------------------------------------
' Функция проверки введённых данных на корректность
'----------------------------------------------------------------------
Function ValidateFields()
Dim objFSO
Dim strFullFileName
Dim strValidateResult
Set objFSO = CreateObject("Scripting.FileSystemObject")
ValidateFields = True
strValidateResult = ""
With document
strFullFileName = .getElementByID("SelFile").value
' Указанный или введённый файл должен существовать и иметь расширение Doc/Rtf
If Not objFSO.FileExists(strFullFileName) Or Not ( _
UCase(objFSO.GetExtensionName(strFullFileName)) = "DOC" Or _
UCase(objFSO.GetExtensionName(strFullFileName)) = "RTF" _
) Then
strValidateResult = strValidateResult & "Выбран неверный файл. "
.getElementByID("lblSelFile").className = "NonValid"
.getElementByID("SelFile").className = "NonValid"
ValidateFields = False
End If
' Уникальная фраза для поиска должна быть не пуста
If Len(document.getElementByID("FindTextField").value) = 0 Then
strValidateResult = strValidateResult & "Нужна фраза для поиска."
.getElementByID("lblFindTextField").className = "NonValid"
.getElementByID("FindTextField").className = "NonValid"
ValidateFields = False
End If
.getElementByID("Status").innerText = strValidateResult
End With
Set objFSO = Nothing
End Function
'----------------------------------------------------------------------
'Расстановка меток, основная процедура
'----------------------------------------------------------------------
Sub SetOMR()
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 ' Надпись. Высота
Const strSoundFileName = "tada.wav"
'Const strSoundFileName = "flourish.mid"
Dim objWord ' Объект Microsoft Word
Dim objFSO
Dim PageDictTemp ' Временный словарь страниц с метками
Dim PageDict ' Перенумерованный словарь
Dim FindText ' Фраза для поиска
Dim PrintStatus ' Текст для сообщения. Связан с ReadyToPrint.
Dim StartTime ' Время начала операции расстановки меток.
Dim PageCount ' Количество страниц в документе
Dim ArrItems ' Массив элементов словаря PageDict
Dim FileNameWithOMR ' Имя файла для сохранения
Dim TextBox1 ' Надпись с метками
Dim strTwoLabels ' Строка с двумя метками (для надписи)
Dim strFourLabels ' Строка с четырьмя метками (для надписи)
Dim strDocumentFullFileName
Dim strDocumentNewFullFileName
Dim strSoundFullFileName
Dim i ' Счётчик
'Создание объектов.
Set objWord = CreateObject("Word.Application")
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set PageDictTemp = CreateObject("Scripting.Dictionary")
Set PageDict = CreateObject("Scripting.Dictionary")
FindText = document.getElementByID("FindTextField").value
strDocumentFullFileName = document.getElementByID("SelFile").value
' Строка с двумя метками (для надписи)
strTwoLabels = _
ChrW(&H2500) & ChrW(&H2500) & vbCrLf & _
vbCrLf & _
vbCrLf & _
ChrW(&H2500) & ChrW(&H2500)
' Строка с четырьмя метками (для надписи)
strFourLabels = _
ChrW(&H2500) & ChrW(&H2500) & vbCrLf & _
ChrW(&H2500) & ChrW(&H2500) & vbCrLf & _
ChrW(&H2500) & ChrW(&H2500) & vbCrLf & _
ChrW(&H2500) & ChrW(&H2500)
'Время начала работы
StartTime = Timer
With objWord
'Открытие документа
.Documents.Open(strDocumentFullFileName)
'Количество страниц
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
'"Замораживание"
.ScreenUpdating = False
.System.Cursor = 0
'Перебор по всем страницам
For i = 1 To PageCount
document.getElementByID("Status").innerText = "Обрабатывается страница " & CStr(i) & "."
With .Selection
'"Сброс" выделения и переход на страницу i
.Collapse wdCollapseStart
.GoTo wdGoToAbsolute, wdGoToPage, i
End With
'Создание надписи
Set Textbox1 = .ActiveDocument.Shapes.AddTextbox (msoTextOrientationHorizontal, TextBoxLeft, TextBoxTop, TextBoxWidth, TextBoxHeight)
With Textbox1
'Установка прозрачности границ и фона надписи
.Line.Transparency = 1
.Fill.Transparency = 1
With .TextFrame.TextRange
'Установка характеристик параграфа
With .ParagraphFormat
.LineSpacingRule = 5
.LineSpacing = objWord.LinesToPoints(0.58)
End With
'Установка характеристик шрифта
With .Font
.Name = "Times New Roman"
.Size = 16
End With
'Нанесение меток.
'Если (Страница не последняя) И (На следующей странице нет фразы) То
' Наносим 2 линии
'Иначе
' Наносим 4 линии
'Конец Если
If (i < PageCount) And (ArrItems(i) = 0) Then
.InsertAfter strTwoLabels
Else
.InsertAfter strFourLabels
End If
End With
End With
Next
'"Размораживаем"
.System.Cursor = 2
.ScreenUpdating = True
'Проверка, отправлять ли на печать
If document.getElementByID("PrintAfterProcessing").checked Then
PrintStatus = "Отправлено на печать"
.PrintOut
Else
PrintStatus = "На печать не отправлено"
End If
'Формирование нового имени
strDocumentNewFullFileName = objFSO.BuildPath( _
objFSO.GetParentFolderName(strDocumentFullFileName), _
objFSO.GetBaseName(strDocumentFullFileName) & "_OMR." & _
objFSO.GetExtensionName(strDocumentFullFileName))
'Сохранение под новым именем и закрытие
.ActiveDocument.SaveAs strDocumentNewFullFileName
.ActiveDocument.Close
End With
'Закрытие объекта
objWord.Quit
With document
'Вывод собщения
.getElementByID("Status").innerText = "На обработку затрачено: " & _
TimeSerial(0, 0, Timer - StartTime) & ". " & _
"Файл сохранён как [" & strDocumentNewFullFileName & "]. " & PrintStatus & "."
.getElementByID("SelFile").disabled = False
.getElementByID("FindTextField").disabled = False
.getElementByID("PrintAfterProcessing").disabled = False
.getElementByID("SetOMR").disabled = False
With .getElementByID("tagBody")
With .style
.cursor = "auto"
' Меняем цвет фона приложения
.backgroundColor = "ActiveCaption"
End With
' Задаём остановку индикации через вызов процедуры
' «FlashBodyStop» при движении мышки над рабочим пространством приложения
.onmousemove = GetRef("FlashBodyStop")
End With
' Формируем имя звукового файла для воспроизведения
strSoundFullFileName = objFSO.BuildPath(objFSO.GetSpecialFolder(0), "Media\" & strSoundFileName)
' Если указанный звуковой файл существует…
If objFSO.FileExists(strSoundFullFileName) Then
' Опосредованно задаём звуковой файл для воспроизведения
' через процедуру «PlaySound(…)»
setTimeout "PlaySound(""" & strSoundFullFileName & """)", 0
End If
End With
' Для начала индикации фоном рабочего пространства приложения
' назначаем вызов процедуры «FlashBody()» каждые 0.5 секунды
intIntervalID = setInterval("FlashBody()", 500)
Set PageDict = Nothing
Set PageDictTemp = Nothing
Set objFSO = Nothing
Set objWord = Nothing
End Sub
'----------------------------------------------------------------------
'----------------------------------------------------------------------
Sub PlaySound(strSoundFullFileName)
' Назначаем источник данных для тэга «BGSOUND», после чего
' начнётся фоновое воспроизведение звукового файла
document.getElementByID("Sound").src = strSoundFullFileName
End Sub
'----------------------------------------------------------------------
'----------------------------------------------------------------------
Sub FlashBody()
With document.getElementByID("tagBody").style
' Меняем цвет фона рабочего пространства приложения
' «ActiveCaption» <———> «InactiveCaption»
Select Case UCase(.backgroundColor)
Case UCase("ActiveCaption")
.backgroundColor = "InactiveCaption"
Case UCase("InactiveCaption")
.backgroundColor = "ActiveCaption"
' Если цвет какой-либо иной, останавливаем индикацию
' (здесь больше возможный задел на будущее)
Case Else
FlashBodyStop
End Select
End With
End Sub
'----------------------------------------------------------------------
'----------------------------------------------------------------------
Sub FlashBodyStop()
' …останавливаем периодический вызов процедуры FlashBody
clearInterval intIntervalID
With document
With .getElementByID("tagBody")
' Отключаем отслеживание перемещений мышки
.onmousemove = Nothing
' …задаём стандартный цвет фона рабочего пространства приложения
.style.backgroundColor = "ButtonFace"
End With
' …останавливаем воспроизведение фонового звука,
.getElementByID("Sound").src = ""
End With
End Sub
'----------------------------------------------------------------------
'----------------------------------------------------------------------
' При щелчке мышки на имени принтера, переключить флажок печати
'----------------------------------------------------------------------
Sub lblPrintAfterProcessing_OnClick()
With document.getElementByID("PrintAfterProcessing")
.focus
.checked = Not .checked
End With
End Sub
'----------------------------------------------------------------------
</script>
</head>
<body id="tagBody" scroll="auto">
<span Class="Row">
<span Class="left"><span id="lblSelFile">1. Выберите файл .rtf или .doc</span></span>
<span Class="right"><input type="File" name="SelFile" value="" size="64"></span>
</span>
<span Class="Row">
<span Class="left"><span id="lblFindTextField">2. Введите уникальную фразу</span></span>
<span Class="right"><input type="Text" name="FindTextField" value="" size="40"></span>
</span>
<span Class="Row" id="SectionPrintAfterProcessing">
<span Class="left">3. Установите флажок для печати содержимого документа после обработки</span>
<span Class="right">
<input type="CheckBox" name="PrintAfterProcessing">
<span id="lblPrintAfterProcessing">Печатать документ</span>
</span>
</span>
<span Class="Row">
<span Class="left"><span id="lblSetOMR">4. Нажмите кнопку "Расставить метки"</span></span>
<span Class="right"><input type="Button" name="SetOMR" value="Расставить метки"></span>
</span>
<hr Class="Row" />
<span Class="Row">
<span id="Status"> </span>
</span>
</body>
<script language="VBScript">
Public intIntervalID
Dim objSWbemServices
Dim collSWbemObjectSet_Win32_Printer
Dim objSWbemObjectEx_Win32_Printer
Set objSWbemServices = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
Set collSWbemObjectSet_Win32_Printer = objSWbemServices.ExecQuery("SELECT * FROM Win32_Printer WHERE Default = 'True'")
If collSWbemObjectSet_Win32_Printer.Count <> 0 Then
For Each objSWbemObjectEx_Win32_Printer In collSWbemObjectSet_Win32_Printer
With document
.getElementByID("SectionPrintAfterProcessing").style.display = "inline"
.getElementByID("lblPrintAfterProcessing").innerText = objSWbemObjectEx_Win32_Printer.DeviceID
.getElementByID("PrintAfterProcessing").checked = True
End With
Exit For
Next
Else
With document
.getElementByID("SectionPrintAfterProcessing").style.display = "none"
.getElementByID("lblPrintAfterProcessing").innerText = ""
.getElementByID("PrintAfterProcessing").checked = False
End With
End If
Set collSWbemObjectSet_Win32_Printer = Nothing
Set objSWbemServices = Nothing
'Позиционирование и изменение размера окна
With window
.resizeTo tagBody.scrollWidth + 25, tagBody.scrollHeight + 32
.moveTo (.screen.availWidth - tagBody.offsetWidth) \ 2, (.screen.availHeight - tagBody.offsetHeight) \ 2
End With
</script>
</html>Авторы скрипта MikeSh и alexii.
]]>! если обработка займёт свыше 9 часов 6 минут и 8 секунд, скрипт сломается на функции TimeSerial . Также не учитывается переход через полночь.
* всё, что связано с печатью, — перенесено в саму форму. В принципе, ежели будет потребно, можно по аналогии вместо одного checkbox'а для default-принтера добавить выбор принтера через тег <INPUT TYPE="RADIO">.
+ размер окна подгоняется под содержимое документа; значения «25» и «32» в:
.resizeTo tagBody.scrollWidth + 25, tagBody.scrollHeight + 32подобраны опытным путём для конкретных размеров шрифтов, dpi и темы оформления. Экспериментируйте.
* убрана работа с .Selection при добавлении надписей. Сокращён код.
* вместо отдельных «.InsertSymbol» и «.TypeParagraph» сразу добавляется готовая строка («strTwoLabels» и «strFourLabels»).
* убраны все MsgBox'ы. Их логика переложена на саму форму.
<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-меток в файле MS Word</title>
<hta:Application
Icon = "%ProgramFiles%\Microsoft Office\OFFICE11\WINWORD.EXE"
Id="oHTA"
ApplicationName="Нанесение (расстановка) OMR-меток в файле MS Word"
Border="normal"
BorderStyle="normal"
Caption="yes"
ContextMenu="no"
InnerBorder="yes"
MaximizeButton="no"
MinimizeButton="yes"
Navigable="no"
Scroll="auto"
ScrollFlat="no"
Selection="no"
ShowInTaskbar="yes"
SingleInstance="yes"
SysMenu="yes"
Version="1.4 RC0"
WindowState="normal"
/>
<style type="text/css">
BODY {
font: x-small Verdana, Arial, sans-serif;
}
.Row{
clear:both;
}
.Left{
float:Left;
clear:none;
}
.Right{
float:Right;
clear:none;
}
.NonValid { color:FireBrick; }
#Status { font: xx-small; }
</style>
<script language="VBScript">
Option Explicit
'----------------------------------------------------------------------
Sub SetOMR_OnClick
If ValidateFields() Then
With document
.getElementByID("Status").innerText = "Идёт обработка…"
.getElementByID("SelFile").disabled = True
.getElementByID("FindTextField").disabled = True
.getElementByID("PrintAfterProcessing").disabled = True
.getElementByID("SetOMR").disabled = True
.getElementByID("tagBody").style.cursor = "wait"
End With
setTimeout "SetOMR", 0
End If
End Sub
'----------------------------------------------------------------------
'----------------------------------------------------------------------
Sub SetOMR_OnBlur()
With document
.getElementByID("Status").innerText = ""
.getElementByID("lblSelFile").className = ""
.getElementByID("SelFile").className = ""
.getElementByID("lblFindTextField").className = ""
.getElementByID("FindTextField").className = ""
End With
End Sub
'----------------------------------------------------------------------
'----------------------------------------------------------------------
Function ValidateFields()
Dim objFSO
Dim strFullFileName
Dim strValidateResult
Set objFSO = CreateObject("Scripting.FileSystemObject")
ValidateFields = True
strValidateResult = ""
With document
strFullFileName = .getElementByID("SelFile").value
If Not objFSO.FileExists(strFullFileName) Or Not ( _
UCase(objFSO.GetExtensionName(strFullFileName)) = "DOC" Or _
UCase(objFSO.GetExtensionName(strFullFileName)) = "RTF" _
) Then
strValidateResult = strValidateResult & "Выбран неверный файл. "
.getElementByID("lblSelFile").className = "NonValid"
.getElementByID("SelFile").className = "NonValid"
ValidateFields = False
End If
If Len(document.getElementByID("FindTextField").value) = 0 Then
strValidateResult = strValidateResult & "Нужна фраза для поиска."
.getElementByID("lblFindTextField").className = "NonValid"
.getElementByID("FindTextField").className = "NonValid"
ValidateFields = False
End If
.getElementByID("Status").innerText = strValidateResult
End With
Set objFSO = Nothing
End Function
'----------------------------------------------------------------------
'Расстановка меток, основная процедура
'----------------------------------------------------------------------
Sub SetOMR()
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 PrintStatus ' Текст для сообщения. Связан с ReadyToPrint.
Dim StartTime ' Время начала операции расстановки меток.
Dim PageCount ' Количество страниц в документе
Dim ArrItems ' Массив элементов словаря PageDict
Dim FileNameWithOMR ' Имя файла для сохранения
Dim TextBox1 ' Надпись с метками
Dim strTwoLabels ' Строка с двумя метками (для надписи)
Dim strFourLabels ' Строка с четырьмя метками (для надписи)
Dim i ' Счётчик
'Создание объектов.
Set objWord = CreateObject("Word.Application")
Set PageDictTemp = CreateObject("Scripting.Dictionary")
Set PageDict = CreateObject("Scripting.Dictionary")
FindText = document.getElementByID("FindTextField").value
' Строка с двумя метками (для надписи)
strTwoLabels = _
ChrW(&H2500) & ChrW(&H2500) & vbCrLf & _
vbCrLf & _
vbCrLf & _
ChrW(&H2500) & ChrW(&H2500)
' Строка с четырьмя метками (для надписи)
strFourLabels = _
ChrW(&H2500) & ChrW(&H2500) & vbCrLf & _
ChrW(&H2500) & ChrW(&H2500) & vbCrLf & _
ChrW(&H2500) & ChrW(&H2500) & vbCrLf & _
ChrW(&H2500) & ChrW(&H2500)
'Время начала работы
StartTime = Timer
With objWord
'Открытие документа
.Documents.Open(document.getElementByID("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
'"Замораживание"
.ScreenUpdating = False
.System.Cursor = 0
'Перебор по всем страницам
For i = 1 To PageCount
document.getElementByID("Status").innerText = "Обрабатывается страница " & CStr(i) & "."
With .Selection
'"Сброс" выделения и переход на страницу i
.Collapse wdCollapseStart
.GoTo wdGoToAbsolute, wdGoToPage, i
End With
'Создание надписи
Set Textbox1 = .ActiveDocument.Shapes.AddTextbox (msoTextOrientationHorizontal, TextBoxLeft, TextBoxTop, TextBoxWidth, TextBoxHeight)
With Textbox1
'Установка прозрачности границ и фона надписи
.Line.Transparency = 1
.Fill.Transparency = 1
With .TextFrame.TextRange
'Установка характеристик параграфа
With .ParagraphFormat
.LineSpacingRule = 5
.LineSpacing = objWord.LinesToPoints(0.58)
End With
'Установка характеристик шрифта
With .Font
.Name = "Times New Roman"
.Size = 16
End With
'Нанесение меток.
'Если (Страница не последняя) И (На следующей странице нет фразы) То
' Наносим 2 линии
'Иначе
' Наносим 4 линии
'Конец Если
If (i < PageCount) And (ArrItems(i) = 0) Then
.InsertAfter strTwoLabels
Else
.InsertAfter strFourLabels
End If
End With
End With
Next
'"Размораживаем"
.System.Cursor = 2
.ScreenUpdating = True
'Проверка, отправлять ли на печать
If document.getElementByID("PrintAfterProcessing").checked Then
PrintStatus = "Отправлено на печать"
.PrintOut
Else
PrintStatus = "На печать не отправлено"
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
With document
'Вывод собщения
.getElementByID("Status").innerText = "На обработку затрачено: " & _
TimeSerial(0, 0, Timer - StartTime) & ". " & _
"Файл сохранён как " & FileNameWithOMR & ". " & PrintStatus & "."
.getElementByID("SelFile").disabled = False
.getElementByID("FindTextField").disabled = False
.getElementByID("PrintAfterProcessing").disabled = False
.getElementByID("SetOMR").disabled = False
.getElementByID("tagBody").style.cursor = "auto"
End With
End Sub
'----------------------------------------------------------------------
</script>
</head>
<body id="tagBody" bgcolor="#afb0b0" background="" scroll="auto">
<span Class="Row">
<span Class="left"><span id="lblSelFile">1. Выберите файл .rtf или .doc</span></span>
<span Class="right"><input type="File" name="SelFile" value="C:\0002\q.doc" size="64"></span>
</span>
<span Class="Row">
<span Class="left"><span id="lblFindTextField">2. Введите уникальную фразу</span></span>
<span Class="right"><input type="Text" name="FindTextField" value="" size="40"></span>
</span>
<span Class="Row" id="SectionPrintAfterProcessing">
<span Class="left">3. Установите флажок для печати содержимого документа после обработки</span>
<span Class="right">
<input type="CheckBox" name="PrintAfterProcessing">
<span id="lblPrintAfterProcessing">Печатать документ</span>
</span>
</span>
<span Class="Row">
<span Class="left"><span id="lblSetOMR">4. Нажмите кнопку "Расставить метки"</span></span>
<span Class="right"><input type="Button" name="SetOMR" value="Расставить метки"></span>
</span>
<hr Class="Row" />
<span Class="Row">
<span id="Status"> </span>
</span>
</body>
<script language="VBScript">
Dim objSWbemServices
Dim collSWbemObjectSet_Win32_Printer
Dim objSWbemObjectEx_Win32_Printer
Set objSWbemServices = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
Set collSWbemObjectSet_Win32_Printer = objSWbemServices.ExecQuery("SELECT * FROM Win32_Printer WHERE Default = 'True'")
If collSWbemObjectSet_Win32_Printer.Count <> 0 Then
For Each objSWbemObjectEx_Win32_Printer In collSWbemObjectSet_Win32_Printer
With document
.getElementByID("SectionPrintAfterProcessing").style.display = "inline"
.getElementByID("lblPrintAfterProcessing").innerText = objSWbemObjectEx_Win32_Printer.DeviceID
.getElementByID("PrintAfterProcessing").checked = True
End With
Exit For
Next
Else
With document
.getElementByID("SectionPrintAfterProcessing").style.display = "none"
.getElementByID("lblPrintAfterProcessing").innerText = ""
.getElementByID("PrintAfterProcessing").checked = False
End With
End If
Set collSWbemObjectSet_Win32_Printer = Nothing
Set objSWbemServices = Nothing
'Позиционирование и изменение размера окна
With window
.resizeTo tagBody.scrollWidth + 25, tagBody.scrollHeight + 32
.moveTo (.screen.availWidth - tagBody.offsetWidth) \ 2, (.screen.availHeight - tagBody.offsetHeight) \ 2
End With
</script>
</html>Авторы скрипта MikeSh и alexii.
]]>"А не замахнуться ли нам на ВильЯма нашего, так сказать, Шекспира?" (цитата из фильма, может и не точная).
Немного предыстории.
В конторе куча корреспонденции, для её упаковки приобретена конвертовальная машина. Ежели бы в каждый конверт ложилось фиксированное количество листов, то вопрос бы не возник… Машина умеет читать 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.
]]>