1

Тема: Таблицы и колонтитулы

Перед тем, как написать сюда, попытатался найти решение в инете, но ничего не смог найти.
А вопрос вот в чем - написал две процедуры (по мотивам макросов, приведенных в книге уважаемого админа), которые изменяют ширину всех (или одной) таблиц по ширине текста (у Антона было - по ширине окна, так что есть небольшая разница). И отладил эти макросы для документов с несколькими разделами, в которых ориентация страницы и форматы бумаги могут быть разными. Все работает. Осталось сделать то же самое с таблицами в колонтитуле. Вот тут и наступил ступор. Может кто сталкивался с такой проблемой? Знаю (из других страниц в инете), что как минимум еще один зарегистрированный тут пользователь хотел бы узнать решение данной задачи:)

Привожу код основных процедур:

Макрос для всех таблиц в основном тексте:

Sub AllTablesAutoFitTextWidth()
'Выравнивание всех таблиц по ширине текста
' Написан по мотивам макроса А.Кокина из книги
' "Word 2003/2007. Народные советы"
Dim arTable As Table ' определение таблицы как объекта "Таблица"
Dim arCurrentDoc As Document 'определение документа как объект "Документ"
Dim arPageWidth As Single ' Ширина страниц
Dim arLeftMargin As Single 'Отступ текста от левого края страницы
Dim arRightMargin As Single ' Отступ текста от правого края страницы
Dim arTableWidth As Single ' Ширина таблицы
Dim arIndexOfSections As Integer
Dim arMeter As Integer
Dim arStoryRangNumber As Integer
arIndexOfSections = ActiveDocument.Sections.Count
Set arCurrentDoc = ActiveDocument ' присвоение переменной имени текущего документа
For arMeter = 1 To arIndexOfSections ' от первого до последнего раздела
    arPageWidth = arCurrentDoc.Sections(arMeter).PageSetup.PageWidth ' присвоение переменной текущей ширины страницы
    arLeftMargin = arCurrentDoc.Sections(arMeter).PageSetup.LeftMargin ' присвоение переменной значения отступа текста от левого края страницы
    arRightMargin = arCurrentDoc.Sections(arMeter).PageSetup.RightMargin ' присвоение переменной значения отступа текста от правого края страницы
    arTableWidth = arPageWidth - (arLeftMargin + arRightMargin) 'Расчет ширины таблицы исходя из текущих значений переменных
    For Each arTable In ActiveDocument.Sections(arMeter).Range.Tables ' для каждой таблицы в выделенном разделе
        arTable.Rows.Alignment = wdAlignRowCenter 'выравнивание таблицы по центру страницы
        arTable.Rows.LeftIndent = CentimetersToPoints(0) 'измерение ширины в сантиметрах
        arTable.PreferredWidthType = wdPreferredWidthPoints 'тип автоподбора ширины таблицы
        arTable.PreferredWidth = arTableWidth 'собственно задание таблице ее новой ширины
    Next arTable ' работа со следующей таблицей
Next arMeter
End Sub

Макрос для отдельно выбранной таблице (курсор должен быть внутри таблицы):

Sub SingleTableAutoFitTextWidth()
'Выравнивание выбранной таблицы по ширине текста
' Написан по мотивам макроса А.Кокина из книги
' "Word 2003/2007. Народные советы"
Dim arTable As Table
Dim arCurrentDoc As Document
Dim arPageWidth As Single
Dim arLeftMargin As Single
Dim arRightMargin As Single
Dim arTableWidth As Single

Set arCurrentDoc = ActiveDocument
    arLeftMargin = 0
    arRightMargin = 0
With Selection
    Set arTable = .Tables(1)
    arPageWidth = .Range.Sections.PageSetup.PageWidth
    arLeftMargin = .Range.Sections.PageSetup.LeftMargin
    arRightMargin = .Range.Sections.PageSetup.RightMargin
End With
    arTableWidth = arPageWidth - (arLeftMargin + arRightMargin)
    arTable.Rows.Alignment = wdAlignRowCenter
    arTable.Rows.LeftIndent = CentimetersToPoints(0)
    arTable.PreferredWidthType = wdPreferredWidthPoints
    arTable.PreferredWidth = arTableWidth

End Sub

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

Подсознательно кажется, что нужно работать с цепочками (как в книге внешняя ссылка), но пока не смог разобраться, как эти цепочки применить к таблицам:(
Прошу посильной помощи!

ps. Макрорекордером записал вот такой вот код (для трех разделов):
Sub Макрос1()
'
' Макрос1 Макрос
'
    If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
        ActiveWindow.Panes(2).Close
    End If
    If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow. _
        ActivePane.View.Type = wdOutlineView Then
        ActiveWindow.ActivePane.View.Type = wdPrintView
    End If
    ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
    Selection.Tables(1).Select
    Selection.Tables(1).PreferredWidthType = wdPreferredWidthPoints
    Selection.Tables(1).PreferredWidth = CentimetersToPoints(17)
    ActiveWindow.ActivePane.View.NextHeaderFooter
    Selection.Tables(1).Select
    Selection.Tables(1).Rows.Alignment = wdAlignRowCenter
    Selection.Tables(1).Rows.LeftIndent = CentimetersToPoints(0)
    Selection.Tables(1).PreferredWidthType = wdPreferredWidthPoints
    Selection.Tables(1).PreferredWidth = CentimetersToPoints(17)
    ActiveWindow.ActivePane.View.NextHeaderFooter
    Selection.Tables(1).Select
    Selection.Tables(1).Rows.Alignment = wdAlignRowCenter
    Selection.Tables(1).Rows.LeftIndent = CentimetersToPoints(0)
    Selection.Tables(1).PreferredWidthType = wdPreferredWidthPoints
    Selection.Tables(1).PreferredWidth = CentimetersToPoints(17)

ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument

End Sub

его конечно можно переделать нормально, но суть не в этом, а в том, что он работает, когда в колонтитуле сверху вниз идут сначала таблица, а потом знак абзаца. Если знак абзаца стоит перед таблицей - естественно, данный макрос не работает, отсюда и вопрос, приведенный выше, как выбрать программно таблицу в колонтитулах..

2

Re: Таблицы и колонтитулы

Андрей, если я верно понял, то вам нужно для всех таблиц во всех колонтитулах всех разделов сделать автоподбор по содержимому этих таблиц (ячеек в них)?
Попробуйте такой макрос:

Sub tblHF()
Dim hRange As Range 'диапазон верхних колонтитулов
Dim fRange As Range 'диапазон нижних колонтитулов
Dim tbl As Table
Dim sec As Section
For Each sec In ActiveDocument.Sections
Set fRange = sec.Footers(wdHeaderFooterPrimary).Range
Set hRange = sec.Headers(wdHeaderFooterPrimary).Range
    For Each tbl In hRange.Tables
      tbl.AutoFitBehavior wdAutoFitContent
    Next tbl
    For Each tbl In fRange.Tables
      tbl.AutoFitBehavior wdAutoFitContent
    Next tbl
Next sec
Set fRange = Nothing
Set hRange = Nothing
End Sub

P.S. Поправил код для всех колонтитулов (нижних и верхних)

Отредактировано admin (30.03.2010 10:02:23)

3

Re: Таблицы и колонтитулы

Немного не так. не по содержимому, а по ширине текста абзацев документа, которая является разницей между шириной страницы и полями. но это не суть важно. самое главное - перебор всех колонтитулов. сейчас попробую ваш метод! и вечером сообщу о результатах.

4

Re: Таблицы и колонтитулы

Антон, не работает для четных страниц.

5

Re: Таблицы и колонтитулы

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

6

Re: Таблицы и колонтитулы

Смогу только вечером, так как пишу с телефона. да я просто создал документ с несколькими разделами и в них уже накидал таблиц везде:) добавил два диапазона для четных верхних и нижних. все отрабатывает! спасибо большое! под себя приспособить - уже дело времени и техники:)
Оказывается, еще нужно проверять и первые страницы (в том случае, стоит флаг отличать их, так же как и для четных, нечетных).
Прикладываю файл. В нем три раздела, разного размера, разной ориентации, с разными колонтитулами первой, четной и нечетной страниц.
В жизни такой документ вряд ли будет, но для отладки, я думаю - самое то!

Да, и еще - может все же есть возможность решить задачу с использованием StoryRange?

Ведь там в StoryType как раз есть все константы отвечающие за разные колонтитулы (спасибо Марку за книгу (страница 380, таблица 16.1))  :

wdEvenPagesHeaderStory - Верхний колонтитул четных страниц
wdPrimaryHeaderStory - Основной верхний колонтитул (как я понял он отвечает за нечетный колонтитул)
wdEvenPagesFooterStory - Нижний колонтитул четных страниц
wdPrimaryFooterStory - Основной нижний колонтитул
wdFirstPageHeaderStory - Верхний колонтитул первой страницы
wdFirstPageFooterStory - Нижний колонтитул первой страницы

Как раз шесть возможных для отдельно взятого раздела, что и получается, если к алгоритму Антона добавить еще два диапазона для вернего и два для нижнего колонтитулов

Отредактировано andrkar (30.03.2010 17:09:31)

Post's attachments

Таблицы.doc 85.5 Кб, 4 скачиваний с 2010-03-30 

You don't have the permssions to download the attachments of this post.

7

Re: Таблицы и колонтитулы

Вот что получилось при переработке алгоритма, предложенного Антоном:

Sub tblHF()
Dim hRange As Range ' диапазон верхних колонтитулов
Dim ehRange As Range ' диапазон верхних четных колонтитулов
Dim fhRange As Range ' диапазон верхних колонтитулов первых страниц
Dim fRange As Range ' диапазон нижних колонтитулов
Dim efRange As Range ' диапазон нижних четных колонтитулов
Dim ffRange As Range ' диапазон нижних колонтитулов первых страниц
Dim tbl As Table
Dim sec As Section
Dim PageWidth As Single ' Ширина страниц
Dim LeftMargin As Single 'Отступ текста от левого края страницы
Dim RightMargin As Single ' Отступ текста от правого края страницы
Dim TableWidth As Single
Dim CurrentDoc As Document
Set CurrentDoc = ActiveDocument ' присвоение переменной имени текущего документа
Dim i As Integer
i = 1
For Each sec In ActiveDocument.Sections
        PageWidth = CurrentDoc.Sections(i).PageSetup.PageWidth
        LeftMargin = CurrentDoc.Sections(i).PageSetup.LeftMargin
        RightMargin = CurrentDoc.Sections(i).PageSetup.RightMargin
        TableWidth = PageWidth - (LeftMargin + RightMargin)
    Set hRange = sec.Headers(wdHeaderFooterPrimary).Range 
    Set ehRange = sec.Headers(wdHeaderFooterEvenPages).Range
    Set fhRange = sec.Headers(wdHeaderFooterFirstPage).Range
    Set fRange = sec.Footers(wdHeaderFooterPrimary).Range
    Set efRange = sec.Footers(wdHeaderFooterEvenPages).Range
    Set ffRange = sec.Footers(wdHeaderFooterFirstPage).Range

    For Each tbl In fhRange.Tables
        tbl.Rows.Alignment = wdAlignRowCenter
        tbl.Rows.LeftIndent = CentimetersToPoints(0)
        tbl.PreferredWidthType = wdPreferredWidthPoints
        tbl.PreferredWidth = TableWidth
    Next tbl
    For Each tbl In ffRange.Tables
        tbl.Rows.Alignment = wdAlignRowCenter
        tbl.Rows.LeftIndent = CentimetersToPoints(0)
        tbl.PreferredWidthType = wdPreferredWidthPoints
        tbl.PreferredWidth = TableWidth
    Next tbl
    For Each tbl In hRange.Tables
        tbl.Rows.Alignment = wdAlignRowCenter
        tbl.Rows.LeftIndent = CentimetersToPoints(0)
        tbl.PreferredWidthType = wdPreferredWidthPoints
        tbl.PreferredWidth = TableWidth
    Next tbl
    For Each tbl In fRange.Tables
        tbl.Rows.Alignment = wdAlignRowCenter
        tbl.Rows.LeftIndent = CentimetersToPoints(0)
        tbl.PreferredWidthType = wdPreferredWidthPoints
        tbl.PreferredWidth = TableWidth
    Next tbl
    For Each tbl In ehRange.Tables
        tbl.Rows.Alignment = wdAlignRowCenter
        tbl.Rows.LeftIndent = CentimetersToPoints(0)
        tbl.PreferredWidthType = wdPreferredWidthPoints
        tbl.PreferredWidth = TableWidth
    Next tbl
    For Each tbl In efRange.Tables
        tbl.Rows.Alignment = wdAlignRowCenter
        tbl.Rows.LeftIndent = CentimetersToPoints(0)
        tbl.PreferredWidthType = wdPreferredWidthPoints
        tbl.PreferredWidth = TableWidth
    Next tbl
    i = i + 1
Next sec
Set fRange = Nothing
Set hRange = Nothing
Set efRange = Nothing
Set ehRange = Nothing
Set fhRange = Nothing
Set ffRange = Nothing
End Sub

С приведенным выше файлом отрабатывает все возможные варианты.
Вопрос вот в чем - можно ли этот код как-то оптимизировать, чтобы не повторять для одни и те же действия шесть раз для разных диапазонов??
Ну и вопрос по StoryRange тоже остается открытым.
Буду благодарен всем откликнувшимся!

Отредактировано andrkar (30.03.2010 19:17:20)

8

Re: Таблицы и колонтитулы

Можно попробовать функцию сделать для выравнивания, а уже в коде передавать эти диапазоны в функцию.

9

Re: Таблицы и колонтитулы

именно это и пробовал делать, но, пока еще, на это мозгов не хватает:)

10

Re: Таблицы и колонтитулы

Судя по всему, никто уже не подскажет на вопрос о функциях? Ну да ладно, это не критично. Макрос уже поставлен на несколько машин и уже оправдал свое создание вкупе с еще одним:)

11

Re: Таблицы и колонтитулы

Андрей, вот попробуйте такой вариант с функцией:

Option Explicit
Dim hRange As Range ' диапазон верхних колонтитулов
Dim ehRange As Range ' диапазон верхних четных колонтитулов
Dim fhRange As Range ' диапазон верхних колонтитулов первых страниц
Dim fRange As Range ' диапазон нижних колонтитулов
Dim efRange As Range ' диапазон нижних четных колонтитулов
Dim ffRange As Range ' диапазон нижних колонтитулов первых страниц
Dim tbl As Table
Dim PageWidth As Single ' Ширина страниц
Dim LeftMargin As Single 'Отступ текста от левого края страницы
Dim RightMargin As Single ' Отступ текста от правого края страницы
Dim TableWidth As Single  'Ширина таблиц
Dim i As Integer

Sub tblHF()
'Выравнивание размеров таблиц по размерам границ текста
'****************************************'
'для каждого раздела в активном документе
For i = 1 To ActiveDocument.Sections.Count
  'устанавливаем диапазоны
  Set hRange = ActiveDocument.Sections(i).Headers(wdHeaderFooterPrimary).Range
  Set ehRange = ActiveDocument.Sections(i).Headers(wdHeaderFooterEvenPages).Range
  Set fhRange = ActiveDocument.Sections(i).Headers(wdHeaderFooterFirstPage).Range
  Set fRange = ActiveDocument.Sections(i).Footers(wdHeaderFooterPrimary).Range
  Set efRange = ActiveDocument.Sections(i).Footers(wdHeaderFooterEvenPages).Range
  Set ffRange = ActiveDocument.Sections(i).Footers(wdHeaderFooterFirstPage).Range
  'вызываем функцию для выравнивания таблиц в каждом диапазоне
  Call tblWidth(tbl, hRange, i)
  Call tblWidth(tbl, ehRange, i)
  Call tblWidth(tbl, fhRange, i)
  Call tblWidth(tbl, fRange, i)
  Call tblWidth(tbl, efRange, i)
  Call tblWidth(tbl, ffRange, i)
Next i
'очищаем память
Set fRange = Nothing
Set hRange = Nothing
Set efRange = Nothing
Set ehRange = Nothing
Set fhRange = Nothing
Set ffRange = Nothing
End Sub

Public Function tblWidth(tbl As Table, rng As Range, sec)
'функция установки ширины таблицы
  'запоминаем текущие размеры страницы раздела
  PageWidth = ActiveDocument.Sections(sec).PageSetup.PageWidth  'ширина страницы
  LeftMargin = ActiveDocument.Sections(sec).PageSetup.LeftMargin  'левый отступ
  RightMargin = ActiveDocument.Sections(sec).PageSetup.RightMargin  'правый отступ
  TableWidth = PageWidth - (LeftMargin + RightMargin) 'требуемая ширина таблицы
  'выполняем выравнивание для каждой таблицы в диапазоне
  For Each tbl In rng.Tables
    With tbl
      .Rows.alignment = wdAlignRowCenter
      .Rows.LeftIndent = CentimetersToPoints(0)
      .PreferredWidth = TableWidth
      .PreferredWidthType = wdPreferredWidthPoints
    End With
  Next tbl
End Function

12

Re: Таблицы и колонтитулы

Спасибо, Антон, завтра обязательно попробую! Сейчас просто над другой задачей работаю..

13

Re: Таблицы и колонтитулы

Добрый день.
А как можно залезть внутрь таблицы (верхний колонтитул) и в ней изменить текст?
В моем примере таблица из двух строк и трех столбцов. Текст во второй ячейке  второй строки выровнять по центру, сделать жирным, задать размер пт.

Ткните ссылкой, если это обсуждалось, пожалуйста.

Post's attachments

ExampleHeaderTableCentreBold.docx 12.73 Кб, 1 скачиваний с 2013-10-21 

You don't have the permssions to download the attachments of this post.

14

Re: Таблицы и колонтитулы

Sub w131021_1458()

With Word.ActiveDocument.Sections(1).Headers(1).Range.Tables(1)
.Rows(2).Cells(2).Range.Text = "555"
.Rows(2).Cells(2).Range.Bold = True
.Rows(2).Cells(2).Range.Font.Size = 20
.Rows(2).Cells(2).Range.Paragraphs(1).Alignment = wdAlignParagraphCenter
End With
End Sub

15

Re: Таблицы и колонтитулы

shanemac51, Спасибо. Но я не совсем правильно сформулировал вопрос. Как это применить к каждому разделу документа, при этом первые разделы могут быть пустыми.

Думаю как то так: но не знаю как дальше...

Sub HeaderBold()
    Dim S As Word.Section
    Dim F As Word.HeaderFooter
   
    For Each S In ActiveDocument.Sections
  
        Set F = S.Headers(wdHeaderFooterPrimary)
        
        If F.Range.Tables.Count <= 0 Then
      
       ' Вот тут надо переход в таблицу ...


    Exit For
       
    Next S
End Sub

16

Re: Таблицы и колонтитулы

попробуйте так  --не проверяла

Sub HeaderBold()
 Dim S As Word.Section
 Dim F As Word.HeaderFooter
 
 For Each S In ActiveDocument.Sections
 
 Set F = S.Headers(wdHeaderFooterPrimary)
 
 If F.Range.Tables.Count > 0 Then

 ' Вот тут надо переход в таблицу ...
With f.Range.Tables(1)
.Rows(2).Cells(2).Range.Text = "555"
.Rows(2).Cells(2).Range.Bold = True
.Rows(2).Cells(2).Range.Font.Size = 20
.Rows(2).Cells(2).Range.Paragraphs(1).Alignment = wdAlignParagraphCenter
End With
endif
 
 
 Next S
End Sub

17

Re: Таблицы и колонтитулы

shanemac51 Я тоже так думал, но нет:
.Rows вот тут ругается...

18

Re: Таблицы и колонтитулы

надо проверять число строк в таблице