1

Тема: HTA: нанесение (расстановка) OMR-меток в файле MS Word

MikeSh пишет:

"А не замахнуться ли нам на ВильЯма нашего, так сказать, Шекспира?" (цитата из фильма, может и не точная).

Немного предыстории.

В конторе куча корреспонденции, для её упаковки приобретена конвертовальная машина. Ежели бы в каждый конверт ложилось фиксированное количество листов, то вопрос бы не возник… Машина умеет читать 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.

2

Re: HTA: нанесение (расстановка) OMR-меток в файле MS Word

OMR 1.4 RC0:

! если обработка займёт свыше 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">&nbsp;</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.

3

Re: HTA: нанесение (расстановка) OMR-меток в файле MS Word

OMR 1.5 RC1:

* окно 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">&nbsp;</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.