Этюды для программистов Microsoft Word

Home ] Up ] Этюд 1.1. Подгонка размера текста ] Этюд 1.2. Изменение регистра символов ] Этюд 1.3. Поиск и раскраска гиперссылок ] Этюд 1.4. Стили ] Этюд 1.5. Вставка форматированного текста ] Этюд 1.6. Вычисление высоты текста. ] Этюд 1.7. Форматирование заголовка. ]


Этюд 1.7. Форматирование заголовка

ЗАГОЛОВОК. Название книги, сочинения или части их; заглавие.

Толковый словарь Ушакова. http://dic.academic.ru/dic.nsf/ushakov/803374

When you pick up a newspaper, watch a show or news, listen to the radio it will be the headlines that grab your attention first especially if it relates to something you want or have been looking for.

http://discuss.joelonsoftware.com/default.asp?biz.5.464080.19

Ресурсы

Шаблон "AhTextHeadline.dot", 59 Кб, формат ZIP [скачать].

Функциональная спецификация

Задача

Форматирование заголовка (или подгонка стиля и размера заголовка) используется в случае, когда заголовок должен поместиться в прямоугольник заданного размера. Будем считать, что задано число строк и ширина заголовка.

Если заголовок создается на основе существующего текста - нужно выделить текст заголовка и нажать кнопку "Headline". Нажатие кнопки "Headline" без выделения текста должно приводить к появлению фиктивного заголовка заданного размера, на месте которого можно ввести текст заголовка позднее.

Нажатие кнопки "Headline" включает режим форматирования заголовка ("Headline On"). Повторное нажатие кнопки "Headline" выключает режим форматирования заголовка ("Headline Off").

В режиме "Headline On" окно Microsoft Word переводится в режим "maximized", левая и правая границы заголовка отображаются линиями синего цвета.

В режиме "Headline Off" исходное состояние окна Microsoft Word восстанавливается, левая и правая границы заголовка не отображаются

Параметры форматирования заголовка

Для форматирования заголовка используются следующие параметры:

Параметр

Тип

Комментарий

Ширина

целое

Ширина заголовка в пунктах (points).

Допустимый диапазон значений [100-600].

Число строк

целое

Число строк.

Допустимый диапазон значений [1-4].

Заполнитель

Символ

Используется для создания фиктивного заголовка. Определен в тексте моделя как строковая константа.

Стиль

Строка

Имя стиля.

Начальные значения параметров заданы в коде модуля в виде констант. Для изменения констант используется диалог AhTextHeadlineSettingsDialog, который вызывается перед входом в режим "Headline On".

Панель инструментов "AhTextHeadline"

Панель инструментов "AhTextHeadline" имеет следующий вид:

Краткое описание кнопок панели инструментов "AhTextHeadline" приведено в следующей таблице.

Кнопка

Краткое описание

Help

Краткая подсказка

Headline

Подгонка размера заголовка.

При первом нажатии кнопки происходит переход в режим форматирования заголовка, в котором отображается рамка заданного размера.

При повторном нажатии кнопки происходит выход из режима форматирования заголовка и возврат в нормальный режим редактирования документа.

Styles

Создание стилей с именами "HeadlineStyle1" и " HeadlineStyle2".

Стили используются для создания заголовков.

Краткая подсказка

Краткая подсказка по кнопкам панели инструментов имеет следующий вид.

Создание стилей

При нажатии кнопки "Styles" создаются два стиля с именами "HeadlineStyle1" и "HeadlineStyle2", используемые для форматирования заголовка. Если хотя бы один из стилей с указанными именами существует, выдается соосбщение и существующие стили не изменяются.

Диалог "Headline settings"

Для ввода параметров форматирования заголовка используется диалог "Headline settings", который имеет следующий вид. Для простоты выбора стиля в списке "Headline styles" отображаются только стили, имена которых начинаются с подстроки "Headline".

Форматирование заголовка на основе существующего текста

Чтобы отформатировать заголовок на основе существующего текста:

1. выделите текст заголовка
2. нажмите кнопку "Headline", чтобы включить режим форматирования заголовка

В диалоге "Выбор стиля для заголовка" выберите нужный стиль, задайте число строк и ширину заголовка и нажмите кнопку "OK".

Произойдет переход в режим форматирования заголовка. Левая и правая границы заданного прямоугольника будут показаны синим цветом. При нажатии кнопки "Cancel" переход в режим форматирования заголовка не происходит.

Выделенный заголовок будет переформатирован на основе выбранных параметров. Текст, не поместившийся в прямоугольник заданного размера, должен быть показан красным цветом.

 

 

 

Пользователь может сократить или удлинить текст заголовка, изменить размер шрифта или изменить межбуквенный интервал с тем, чтобы заголовок поместился в заданный прямоугольник.

 

При наборе текста в режиме форматирования заголовка выходящий за рамки заданного прямоугольника текст не показывается красным цветом.

 

Чтобы убедиться в том, что измененный заголовок "вписывается" в заданный прямоугольник, пользователь должен выйти из режима форматирования заголовка, выделить измененный текст и ещё раз повторить описанную процедуру.

 

Повторное нажатие кнопки "Headline" выключает режим форматирования заголовка. Раскраска границ заданного прямоугольника синим цветом исчезает.

Создание фиктивного заголовка

Чтобы создать фиктивный заголовок, пользователь должен установить курсор в нужное место и нажать кнопку "Headline", не выделяя предварительно никакого текста.

В диалоге "Выбор стиля для заголовка" пользователь выбирает нужный стиль и другие параметры. В случае нажатия кнопки "Cancel" переход в режим форматирования заголовка не происходит. После нажатия кнопки "OK" происходит переход в режим форматирования заголовка. В этом случае левая и правая границы заданного прямоугольника должны быть показаны синим цветом, а заданный прямоугольник должен быть заполнен текстом из повторяющегося нужное число раз символа заполнителя.

На следующей картинке изображен автоматически созданный фиктивный заголовок.

Пользователь вводит  нужный текст на месте фиктивного заголовка или откладывает ввод текста заголовка. При вводе текста пользователь должен сохранить заданное число строк и попытайться вписаться в заданный прямоугольник. Чтобы убедиться в том, что введенный или измененный заголовок вписывается в заданный прямоугольник, пользователь применяет описанную процедуру столько раз, сколько потребуется.

Для реализации поставленной задачи нам понадобится умение работать с закладками. Изучим сначала свойства и методы объекта Bookmark и коллекции Bookmarks.

Реализация. Шаблон "AhTextHeadline.dot"

В шаблоне "AhTextHeadline" содержатся следующие модули:

Модуль

Краткое описание

AhTextHeadline

Основные макросы.

zAhHeadlineStyles

Создание стилей. Исходные тексты этого модуля в книге не приводятся.

AhTextHeadlineSettingsDialog

Диалог "Headline Settings".

Модуль AhTextHeadlineSettingsDialog

В модуле "AhTextHeadlineSettingsDialog" реализован диалог установки параметров форматирования "Headline settings". Диалог "Headline settings" имеет следующий вид.

Члены класса

'
' File AhTextHeadline.dot|AhTextHeadlineSettingsDialog
'
' Etudes for Microsoft Word Programmers.
' Etude 1.7. Headlines.
'
' First published on http://www.transcriber.ru
'
' © 2000-2007. Evgeny Akhundzhanov. All rights reserved.
'
'
Option Explicit
'
' Declarations
'
Public dwDialogResult As Long   ' return value

'
' Constructor
'
Private Sub UserForm_Initialize()
    dwDialogResult = vbCancel

End Sub

Конструктор

'
' Constructor
'
Private Sub UserForm_Initialize()
    dwDialogResult = vbCancel

End Sub

Деструктор

'
' Destructor
'
Private Sub UserForm_Terminate()
End Sub

Процедура InitDialogData

'
' InitDialogData
'
Public Sub InitDialogData(ByVal bInUseOnly As Boolean, ByVal bHeadlineStylesOnly As Boolean)
Dim styl As style
Dim bAddStyle As Boolean

    For Each styl In ActiveDocument.Styles
        '
        ' determine whether to add styl or not
        '
        bAddStyle = False
        If bInUseOnly Then
            If styl.InUse Then
                bAddStyle = True
            End If
        Else
            bAddStyle = True
        End If
        
        If bHeadlineStylesOnly Then
            If styl.NameLocal Like "Headline*" Then
                bAddStyle = True
            Else
                bAddStyle = False
            End If
        End If
        '
        ' add style name to combo box
        '
        If bAddStyle Then
            m_cboxStyles.AddItem styl.NameLocal
        End If
    Next styl
   
    m_tBox_Width.Text = "400"
   
m_tbox_nLines.Text = "2"
   
End Sub

Процедура EnableControls

'
' EnableControls
'
Public Sub EnableControls()
    '
    ' enable Create button depending on m_cboxStyles.ListCount
    '
    Dim iStylesCnt As Long
    iStylesCnt = m_cboxStyles.ListCount
    If iStylesCnt > 0 Then
        m_btnCreate.Enabled = False
        m_btnCreate.Visible = False
        m_btnOK.Enabled = True
    Else
        m_btnOK.Enabled = False
        m_cboxStyles.Enabled = False
    End If
   
       
    If iStylesCnt > 0 Then
        m_cboxStyles.ListIndex = 0
    Else
        m_cboxStyles_Change ' forces valid description
    End If
   
    If m_btnOK.Enabled = False Then Exit Sub
   
    '
    ' check text box (m_tBox_Width)
    '
    If Len(m_tBox_Width.Text) > 0 Then
        g_dwWidthInPoints = CLng(m_tBox_Width.Text)
        If 100 <= g_dwWidthInPoints And g_dwWidthInPoints <= 600 Then
            ' g_dwWidthInPoints is valid
        Else
            m_btnOK.Enabled = False
            Exit Sub
        End If
    Else
        m_btnOK.Enabled = False
        Exit Sub
    End If
   
    '
    ' check text box (m_tbox_nLines)
    '
    If Len(m_tbox_nLines.Text) > 0 Then
        g_dwNumberOfLines = CLng(m_tbox_nLines.Text)
        If 1 <= g_dwNumberOfLines And g_dwNumberOfLines <= 4 Then
            ' g_dwNumberOfLines is valid
        Else
            m_btnOK.Enabled = False
            Exit Sub
        End If
    Else
        m_btnOK.Enabled = False
       
Exit Sub
    End If
   
End Sub

Нажатие кнопки "Cancel"

'
' Cancel button clicked
'
Private Sub m_btnCancel_Click()
    dwDialogResult = vbCancel
    Unload Me
End Sub

Нажатие кнопки "OK"

'
' OK button clicked
'
Private Sub m_btnOK_Click()
    dwDialogResult = vbOK
    g_strSelectedStyle = m_cboxStyles.Text
    g_dwSelectedStyleIndex = m_cboxStyles.ListIndex
    g_dwWidthInPoints = CLng(m_tBox_Width.Text)
    g_dwNumberOfLines = CLng(m_tbox_nLines.Text)
    Unload Me
End Sub
 

Нажатие кнопки "Create"

'
' Create
'
Private Sub m_btnCreate_Click()
    dwDialogResult = vbCancel
    AhHeadlineStylesCreate  ' create styles and
    Unload Me               ' cancel dialog
End Sub
 

Изменение выбранного стиля

'
' CBox Styles Selection changed
'
Private Sub m_cboxStyles_Change()
    On Error GoTo ErrorLabel
    If (m_cboxStyles.ListIndex >= 0) Then
        m_strStyleDesc.Caption = ActiveDocument.Styles(m_cboxStyles.Text).Description
        m_btnOK.Enabled = True
    Else
        m_strStyleDesc.Caption = "No style selected."
        m_btnOK.Enabled = False
    End If
    Exit Sub
ErrorLabel:
    m_strStyleDesc.Caption = "Error. Selected style doesn't exist?"
    m_btnOK.Enabled = False
End Sub

Изменение других параметров

'
' m_tbox_nLines_Change
'
Private Sub m_tbox_nLines_Change()
    EnableControls
End Sub
'
' m_tBox_Width_Change
'
Private Sub m_tBox_Width_Change()
   
EnableControls
End Sub

Модуль zAhHeadlineStyles

Модуль zAhHeadlineStyles содержит следующие функции для работы со стилями:

Public Function AhStyleExists(ByVal strStyleName As String) As Boolean
Sub AhCreateHeadlineStyles()

Функции этого модуля "похожи" на функции, которые были рассмотрены ранее в Этюде 4 "Стили". Поэтому их исходные тексты здесь не приводятся.

Модуль AhTextHeadline

В модуле "AhTextHeadline" реализованы следующие основные и вспомогательные функции:

  • возврат в нормальное состояние
  • создание фиктивного заголовка
  • форматирование выделенного текста
  • создание и удаление границ (Borders)
  • создание и удаление вспомогательных закладок (Bookmarks)
  • создание стилей
  • переход в режим форматирования заголовка
  • вспомогательные функции

 

Объявления

'
' File AhTextHeadline.dot|AhTextHeadline
'
' Etudes for Microsoft Word Programmers.
' Etude 1.7. Headline Fit.
'
' First published on http://www.transcriber.ru
'
' © 2000-2007. Evgeny Akhundzhanov. All rights reserved.
'
Option Explicit

Private bIsInHeadlineMode As Boolean
Private dwOldView As Long
Private dwOldColorIndex As Long
Private dwOldPageFit As Long
Private dwOldWindowState As Long
Private dwOldPercentage As Long
Private bRestoreColorIndex As Boolean

Константы

'
' Constants
'
Private Const cStrThisTemplateName As String = "AhTextHeadline.dot"
Private Const cStrThisTBName As String = "AhTextHeadline"
Private Const cStrHeadlineButtonName As String = "Headline"
Private Const cStrBookMark1 As String = "AhBookmark1"
Private Const cStrBookMark2 As String = "AhBookmark2"
Private Const chAsciiLF As Long = 10
Private Const chAsciiSR As Long = 11
Private Const chAsciiCR As Long = 13
Private Const cbSwitchToBestFit As Boolean = True
Private Const dwColorNormal As Long = wdBlue
Private Const dwColorExtra As Long = wdRed

Параметры

'
' Parameters for Settings dialog (AhTextHeadlineSettingsDialog)
'
Public g_dwSelectedStyleIndex As Long
Public g_strSelectedStyle As String
Public g_dwWidthInPoints As Long
Public g_dwNumberOfLines As Long

'
' Parameters
'
' Private Const cStrHeadlineStyle As String = "Headline2"      ' style to use
' Private Const cdwHeadlineWidth As Long = 400      ' width in points
' Private Const cdwHeadLinesCnt As Long = 2  ' number of lines for head line
Private Const cStrFillChar As String = "A"
'
' Settings
'
Private Const bInUseOnly As Boolean = False
Private Const bHeadlineStylesOnly As Boolean = True

Процедура AhTextHeadlineHelp

'
' AhTextHeadlineHelp
'
Sub AhTextHeadlineHelp()
MsgBox _
    "Etudes for Microsoft Word Programmers." & vbCrLf & _
    "Etude 7. Headline Fit." & vbCrLf & _
    "http://www.transcriber.ru" & vbCrLf & vbCrLf & _
    "Template AhTextHeadline.dot - Headline Fit" & vbCrLf & vbCrLf & _
    "Parameters are as follows:" & vbCrLf & _
    "Fill Character (hardcoded) = " & cStrFillChar & vbCrLf & vbCrLf & _
    "Other settings are selected from the dialog." & vbCrLf & _
    "" & vbCrLf
End Sub

Процедура AhTextHeadline

'
' AhTextHeadline
'
Sub AhTextHeadline()
    AhHeadline
End Sub

Процедура AhTurnHeadlineModeOff

'
' AhTurnHeadlineModeOff
' Call this from extern modules. For example, OnSave and OnClose events.
'
Sub AhTurnHeadlineModeOff()
    If bIsInHeadlineMode Then
        AhHeadline
    Else
        ' do nothing
    End If
    SaveItSelf
End Sub

Процедура SaveItSelf

'
' SaveItSelf - makes template with name cStrThisTemplateName "Saved".
'
Private Sub SaveItSelf()
    Dim tt As Template
    '
    ' find template with predefined name
    '
    For Each tt In Templates
        '
        ' Use case-insensitive compare for file names.
        '
        If LCase(tt.Name) = LCase(cStrThisTemplateName) Then
            tt.Saved = True
        End If
    Next tt
    ' Ah! 01-Oct-2007. ### Attached template. ###
End Sub

Функция DoSelectStyleDialog

'
' DoSelectStyleDialog
'
Private Function DoSelectStyleDialog(ByRef strSelStyleName As String) As Boolean
    DoSelectStyleDialog = False
    Dim dlg As AhTextHeadlineSettingsDialog
    Set dlg = New AhTextHeadlineSettingsDialog
    With dlg
        '
        ' loop through document styles (cbHeadlineStylesONLY)
        '
        .InitDialogData bInUseOnly, bHeadlineStylesOnly
       
        ' testing error case
        '.m_cboxStyles.AddItem "HL Style 1 (doesn't exist)"
       
        .EnableControls
        .Show vbModal
        If dlg.dwDialogResult = vbOK Then
            DoSelectStyleDialog = True
            strSelStyleName = g_strSelectedStyle
            'MsgBox "index = " & .dwListIndex & vbCrLf & _
            '"g_index = " & g_dwSelectedStyleIndex & " g_Style = " & g_strSelectedStyle
        End If
    End With
    Set dlg = Nothing
End Function

Процедура AhHeadlineStylesCreate

'
' AhHeadlineStylesCreate
'
Public Sub AhHeadlineStylesCreate()
    If Documents.Count <= 0 Then Exit Sub
    AhCreateHeadlineStyles
End Sub

Процедура AhHeadline

'
' AhHeadline
'
Private Sub AhHeadline()
If Documents.Count <= 0 Then Exit Sub
Dim bHeadlineResult As Boolean

SaveItSelf

bHeadlineResult = True
   
If bIsInHeadlineMode Then
    '
    ' exit Headline mode
    '
    AhHeadlineRemove
    AhSetButtonState msoButtonUp
Else
    Dim strSelStyleName As String
    If Not DoSelectStyleDialog(strSelStyleName) Then
        Exit Sub
    End If
    '
    ' enter Headline mode
    '
    AhSetButtonState msoButtonDown
       
    Application.ScreenUpdating = False
   
    Dim dwHeadlineWidth As Long
    Dim dwHeadLinesCnt As Long
    '
    ' hardcoded Settings
    '
    ' dwHeadlineWidth = cdwHeadlineWidth
    ' dwHeadLinesCnt = cdwHeadLinesCnt
    '
    ' Settings from the dialog
    '
    dwHeadlineWidth = g_dwWidthInPoints     ' from Settings dialog
    dwHeadLinesCnt = g_dwNumberOfLines
   
    '
    ' Ah! 25-Jan-2006. Test data for full page width.
    '
    'With ActiveDocument.PageSetup
    '    dwHeadlineWidth = .PageWidth - .RightMargin - .LeftMargin
    'End With
   
    bHeadlineResult = AhHeadlineNew(dwHeadlineWidth, dwHeadLinesCnt, strSelStyleName, cStrFillChar)
    If Not bHeadlineResult Then
        AhSetButtonState msoButtonUp
    End If
    Application.ScreenUpdating = True
End If
'
' switch Headline mode
'
If bHeadlineResult Then
    bIsInHeadlineMode = Not bIsInHeadlineMode
    ' Debug.Print "bIsInHeadlineMode = ", bIsInHeadlineMode
End If
   
SaveItSelf
End Sub

Процедура AhSetButtonState

'
' AhSetButtonState
'
Private Sub AhSetButtonState(ByVal msoButtonState As Long)
     CommandBars(cStrThisTBName).Controls(cStrHeadlineButtonName).State = msoButtonState
End Sub

Процедура AhSwitchToPageView


'
' AhSwitchToPageView
'
Private Sub AhSwitchToPageView(ByVal bSwitchToPageView As Boolean)
If bSwitchToPageView Then
    dwOldView = ActiveWindow.View.Type
    ActiveWindow.View.Type = wdPageView
Else
    ActiveWindow.View.Type = dwOldView
End If
End Sub

Функция AhHeadlineNew

'
' AhHeadlineNew
'
Private Function AhHeadlineNew(ByVal dwPoints As Long, ByVal dwHeaderNumLines As Long, ByVal strHeaderStyle As String, ByVal strDummy As String) As Boolean
Dim fParagraphSize As Single

    On Error GoTo ErrorLabel
    AhRemoveBookMarks
    fParagraphSize = ActiveDocument.PageSetup.PageWidth - _
        ActiveDocument.PageSetup.RightMargin - _
        ActiveDocument.PageSetup.LeftMargin - dwPoints
   
    If fParagraphSize < 0 Then
        MsgBox "Invalid Paragraph Size", vbOKOnly + vbExclamation
        AhHeadlineNew = False
        Exit Function
    End If
   
    AhSwitchToPageView True
   
    If (Selection.End - Selection.Start) <> 0 Then
        AhHeadlineSel fParagraphSize, strHeaderStyle, dwHeaderNumLines
    Else
        AhHeadlineNoSel fParagraphSize, strHeaderStyle, dwHeaderNumLines, strDummy
    End If
   
    AhBookMarkCreate cStrBookMark1
    AhBorderCreate
   
    If cbSwitchToBestFit Then
        AhSwitchToBestFit True
    End If
    AhHeadlineNew = True
    Exit Function
ErrorLabel:
    MsgBox "Error in AhHeadlineNew"
    AhHeadlineNew = False
End Function

Процедура AhSwitchToBestFit

'
' AhSwitchToBestFit
'
Private Sub AhSwitchToBestFit(ByVal bSwitchToBestFit As Boolean)
With ActiveWindow
    If bSwitchToBestFit Then
        dwOldPageFit = .ActivePane.View.Zoom.PageFit
        dwOldWindowState = .WindowState
        dwOldPercentage = .ActivePane.View.Zoom.Percentage
   
        .ActivePane.View.Zoom.PageFit = wdPageFitBestFit
        .WindowState = wdWindowStateMaximize
    Else
        .ActivePane.View.Zoom.PageFit = dwOldPageFit
        .ActivePane.View.Zoom.Percentage = dwOldPercentage
        .WindowState = dwOldWindowState
    End If
End With
End Sub

Процедура AhHeadlineSel

'
' AhHeadlineSel
'
Private Sub AhHeadlineSel(ByVal fParagraphSize As Single, ByVal strHeaderStyle As String, ByVal dwHeaderNumLines As Long)
Dim dwSelBeg As Long
Dim dwSelEnd As Long
Dim dwHeadlineEnd As Long
Dim dwChar As Long

With Selection

    dwSelBeg = .Start
    dwSelEnd = .End
    
    If (dwSelBeg <> 0) Then
        .Start = .Start - 1
        .End = .Start + 1
        dwChar = Asc(.Characters.Last)
        If (dwChar <> chAsciiCR) And (dwChar <> chAsciiLF) Then
            .InsertParagraphAfter
            dwSelBeg = dwSelBeg + 1
            dwSelEnd = dwSelEnd + 1
        End If
    End If
   
    .Start = dwSelBeg
    .End = dwSelEnd
    dwChar = Asc(.Characters.Last)
    If (dwChar <> chAsciiCR) And (dwChar <> chAsciiLF) Then
        .InsertParagraphAfter
        dwSelEnd = dwSelEnd + 1
    End If
   
    With .ParagraphFormat
        .style = strHeaderStyle
        dwOldColorIndex = .style.Font.ColorIndex
        .LeftIndent = 0
        .RightIndent = fParagraphSize
    End With
   
    .Start = dwSelBeg
    .End = dwSelBeg
    Dim i As Long
    For i = 1 To dwHeaderNumLines
        .MoveEnd wdLine
       
        '
        ' Ah! 25-Jan-2006. Insert SoftReturn when (width!=PageWidth).
        '
        If (i <> dwHeaderNumLines) Then
            dwChar = Asc(.Characters(.End - .Start))
            If (dwChar <> chAsciiCR) _
            And (dwChar <> chAsciiLF) _
            And (dwChar <> chAsciiSR) Then
                Selection.InsertAfter Text:=Chr(11) ' Soft return.
                dwSelEnd = dwSelEnd + 1
            End If
        End If
       
        If .End >= dwSelEnd Then
            .End = dwSelEnd
            Exit For
        End If
    Next
   
    dwChar = Asc(.Characters.Last)
    If (dwChar <> chAsciiCR) And (dwChar <> chAsciiLF) Then
        .InsertParagraphAfter
        dwSelEnd = dwSelEnd + 1
    End If
    dwHeadlineEnd = .End
   
    If (dwSelEnd - dwHeadlineEnd) > 0 Then
        .Start = dwHeadlineEnd
        .End = dwSelEnd
        AhBookMarkCreate cStrBookMark2
        .Font.ColorIndex = dwColorExtra
    End If
   
    .Start = dwSelBeg
    .End = dwHeadlineEnd
End With
End Sub

Процедура AhHeadlineNoSel

'
' AhHeadlineNoSel
'
Private Sub AhHeadlineNoSel(ByVal fParagraphSize As Single, ByVal strHeaderStyle As String, ByVal dwHeaderNumLines As Long, ByVal strDummy As String)
Dim dwCurLast As Long
Dim dwStart As Long
Dim dwChar As Long
    dwOldColorIndex = -1
   
    With Selection
        dwStart = .Start
        If .Start <> 0 Then
            dwChar = Asc(ActiveDocument.Characters(.Start))
            If (dwChar <> chAsciiCR) And (dwChar <> chAsciiLF) Then
                .MoveStart wdLine
            End If
            dwStart = .Start
            .Start = .Start - 1
            .End = .Start + 1
            dwChar = Asc(.Characters.Last)
            If (dwChar <> chAsciiCR) _
            And (dwChar <> chAsciiLF) _
            And (.Start <> 0) Then
                .InsertParagraphAfter
                dwStart = dwStart + 1
            End If
            .Start = dwStart
        End If
   
        Options.ReplaceSelection = True
   
        .InsertParagraphAfter
       
        '
        ' Ah! 30-Jan-2006. Without .Copy & .Paste - clipboard is not corrupted.
        '
        Dim nLine As Long
        For nLine = 1 To dwHeaderNumLines
            .TypeText UCase(strDummy)
            .Start = dwStart
            .End = dwStart + 2
       
            With .ParagraphFormat
                .style = strHeaderStyle
                .LeftIndent = 0
                .RightIndent = fParagraphSize
                .FirstLineIndent = 0
            End With

            Options.ReplaceSelection = False
       
            dwCurLast = .Start + 1
            Do
                .Start = dwCurLast
                .TypeText strDummy
                dwCurLast = .End
           
                .Start = dwStart
                .End = dwStart
                dwStart = .Start
           
                .MoveDown Unit:=wdLine, Count:=1, Extend:=wdExtend
                If dwCurLast >= .End Then
                    .Start = dwCurLast - 1
                    .End = dwCurLast
                    .Delete
                    Exit Do
                End If
            Loop
            If nLine <> dwHeaderNumLines Then
                .TypeText Chr(11)
            End If
        dwStart = .Start
        .MoveDown Unit:=wdLine, Count:=1, Extend:=wdExtend
        .End = .End - 1
       
        '.Copy   ' this corrupts clipboard
        'Dim i As Long
        'For i = 2 To dwHeaderNumLines
        '    .Paste
        'Next
        Next nLine
       
        .End = .Start
        .MoveDown Unit:=wdLine
        dwCurLast = .Start - 1
        .Start = dwStart
        .End = dwCurLast
    End With
      
    Options.ReplaceSelection = True
End Sub

Процедура AhSetBorderParams

'
' AhSetBorderParams
'
Private Sub AhSetBorderParams(ByVal wdBorderType As Long, ByVal wdLineStyle As Long, ByVal wdLineWidth As Long, ByVal dwColorIndex As Long)
    On Error Resume Next
    With Selection.ParagraphFormat.Borders(wdBorderType)
        .LineStyle = wdLineStyle
        .LineWidth = wdLineWidth
        .ColorIndex = dwColorIndex
    End With
End Sub

Процедура AhSetBorderHide

'
' AhSetBorderHide
'
Private Sub AhSetBorderHide(ByVal wdBorderType As Long)
    On Error Resume Next
    With Selection.ParagraphFormat.Borders(wdBorderType)
        .LineStyle = wdLineStyleNone
    End With
End Sub

Процедура AhSetBorderDistances

'
' AhSetBorderDistances
'
Private Sub AhSetBorderDistances()
    On Error Resume Next
    With Selection.ParagraphFormat.Borders
        .DistanceFromTop = 1
        .DistanceFromLeft = 4
        .DistanceFromBottom = 1
        .DistanceFromRight = 4
        .Shadow = False
    End With
End Sub

Процедура AhSetDefaultBorderOptions

'
' AhSetDefaultBorderOptions
'
Private Sub AhSetDefaultBorderOptions()
    On Error Resume Next
    With Options
        .DefaultBorderLineStyle = wdLineStyleSingle
        .DefaultBorderLineWidth = wdLineWidth050pt
        .DefaultBorderColorIndex = dwColorNormal
    End With
End Sub

Процедура AhBorderCreate

'
' AhBorderCreate
'
Private Sub AhBorderCreate()
    AhSetBorderParams wdBorderLeft, wdLineStyleSingle, wdLineWidth050pt, dwColorNormal
    AhSetBorderParams wdBorderRight, wdLineStyleSingle, wdLineWidth050pt, dwColorNormal
       
    AhSetBorderHide wdBorderTop
    AhSetBorderHide wdBorderBottom
   
    AhSetBorderDistances
    AhSetDefaultBorderOptions
End Sub

Процедура AhBorderRemove

'
' AhBorderRemove
'
Private Sub AhBorderRemove()
    AhSetBorderHide wdBorderLeft
    AhSetBorderHide wdBorderRight
   
    AhSetBorderHide wdBorderTop
    AhSetBorderHide wdBorderBottom
   
    AhSetBorderDistances
    AhSetDefaultBorderOptions
End Sub

Процедура AhBookMarkCreate

'
' AhBookMarkCreate
'
Private Sub AhBookMarkCreate(ByVal strBookMarkName As String)
    With ActiveDocument.Bookmarks
        .Add range:=Selection.range, Name:=strBookMarkName
        .DefaultSorting = wdSortByName
        .ShowHidden = True
    End With
End Sub

Процедура AhBookMarkRemove

'
' AhBookMarkRemove
'
Private Sub AhBookMarkRemove(ByVal strBookMarkName As String)
    On Error Resume Next
    ActiveDocument.Bookmarks(strBookMarkName).Delete
End Sub

Процедура AhBookMarksDump

'
' AhBookMarksDump
'
Sub AhBookMarksDump()
Dim bm As Bookmark
    Debug.Print "AhBookMarksDump +++"
    For Each bm In ActiveDocument.Bookmarks
        Debug.Print bm.Name, bm.range.Start, bm.range.End
    Next bm
    Debug.Print "AhBookMarksDump ==="
    '
    ' Builtin bookmarks are not listed in previous loop.
    '
    Set bm = ActiveDocument.Bookmarks("\Para")
    Debug.Print bm.Name, bm.range.Start, bm.range.End
End Sub

Процедура AhRemoveBookMarks

'
' AhRemoveBookMarks
'
Private Sub AhRemoveBookMarks()
    AhBookMarkRemove cStrBookMark2
    AhBookMarkRemove cStrBookMark1
End Sub
 

Процедура AhGoToBookMark

'
' AhGoToBookMark
'
Private Sub AhGoToBookMark(ByVal strBookMarkName As String)
    On Error GoTo Error
    With Selection
        .GoTo What:=wdGoToBookmark, Name:=strBookMarkName
    End With
Error:
End Sub

Процедура AhHeadlineRemove

'
' AhHeadlineRemove
'
Private Sub AhHeadlineRemove()
    AhGoToBookMark cStrBookMark1
    Selection.ParagraphFormat.RightIndent = 0
   
    AhBorderRemove
   
    AhGoToBookMark cStrBookMark2
    Selection.ParagraphFormat.RightIndent = 0
   
    If (-1 <> dwOldColorIndex) Then
        Selection.Font.ColorIndex = dwOldColorIndex
    End If
    AhRemoveBookMarks
   
    Selection.End = Selection.Start
   
    If cbSwitchToBestFit Then
        AhSwitchToBestFit False
    End If
    AhSwitchToPageView False
End Sub

Выводы

На основе спецификации создан шаблон "AhTextHeadline.dot", который содержит макросы форматирования заголовка и диалог для ввода параметров.

В шаблоне "AhTextHeadline.dot" реализованы следующие функции:

  • создание и удаление границ (Borders)
  • создание и удаление вспомогательных закладок (Bookmarks)
  • создание стилей
  • переход в режим форматирования заголовка
  • возврат в нормальное состояние
  • создание фиктивного заголовка
  • форматирование выделенного текста
  • диалог редактирования параметров
  • вспомогательные функции

Панель инструментов "AhTextHeadline" предоставляет простой интерфейс к операции форматирования заголовка.

Задание 1

 Выбранный стиль в диалоге (и, наверное, другие данные тоже) не сохраняются до следующего вызова  - сделать это Заданием!

 


Этюды для программистов Microsoft Word. Этюд 1.7. Форматирование заголовка.


© 2000-2009 Евгений Ахунджанов, Все Права Сохранены.
www.transcriber.ru | Послать письмо автору