АВТОМАТИЧЕСКИЕ КОЛОНТИТУЛЫ

[provodnikam]

Здравствуйте!!!!
Есть некая папка, в которой лежат файлы .doc
необходимо автоматически в каждый из них вставить один и тот же колонтитутл.
Но проблема в том, что их(файлов) БоЛЕЕ 1000!!!
вручную это долго!!!!
Подскажите, программно можно это сделать с помощью макроса!!!!

[viter.alex]

Можно. Функцией Dir перебирать файлы в каталоге. Вставлять колонтитулы через коллекцию HeadersFooters для каждого раздела в документе. Что не получается?
Я бы и макрос написал, да некогда

Добавлено позже
На скорую руку:

Sub InsertHeadersFooters()
  On Error Resume Next
  Dim sDirectoryPath As String 'Путь к каталогу с файлами
  Dim sFileName As String 'Имя файла
  Dim oDoc As Document 'текущий документ
  Dim oSec As Section 'Раздел документа
  Dim n As Long 'Счетчик документов
  
  'Диалог выбора папки с файлами
  With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "Выберите папку с файлами"
    .ButtonName = "Выбрать"
    .AllowMultiSelect = False
    If .Show Then sDirectoryPath = .SelectedItems(1) Else Exit Sub
  End With
  
  sFileName = Dir(sDirectoryPath & "\*.doc*") 'читаем файлы из папки
  Do While Len(sFileName) > 0 'пока есть имя файла
    'Открываем документ
    Set oDoc = Documents.Open(sDirectoryPath & "\" & sFileName, AddToRecentFiles:=False)
    n = n + 1
    'Перебираем все разделы в документе и задаем текст нижнего и верхнего колонтитулов
    For Each oSec In oDoc.Sections
      oSec.Headers(wdHeaderFooterPrimary).Range.Text = "Верхний колонтитул раздела " & oSec.Index
      oSec.Footers(wdHeaderFooterPrimary).Range.Text = "Нижний колонтитул раздела " & oSec.Index
    Next
    oDoc.Close True 'Закрываем документ
    'Делаем то, что накопилось в системе, чтобы не зависнуть
    DoEvents
    Application.StatusBar = "Обработано " & n & " файлов"
    sFileName = Dir 'Читаем имя следующего файла
  Loop
  'Очищаем мусор
  Set oDoc = Nothing: Set oSec = Nothing: Err.Clear
  'Сообщение о результатах работы
  MsgBox "В каталоге """ & sDirectoryPath & """ обработано " & n & " файлов", vbInformation + vbOKOnly, "Добавление колонтитулов"
End Sub

[provodnikam]

Сообщение от viter.alex

Можно. Функцией Dir перебирать файлы в каталоге. Вставлять колонтитулы через коллекцию HeadersFooters для каждого раздела в документе. Что не получается?
Я бы и макрос написал, да некогда

Добавлено позже
На скорую руку:

Sub InsertHeadersFooters()
  On Error Resume Next
  Dim sDirectoryPath As String 'Путь к каталогу с файлами
  Dim sFileName As String 'Имя файла
  Dim oDoc As Document 'текущий документ
  Dim oSec As Section 'Раздел документа
  Dim n As Long 'Счетчик документов
  
  'Диалог выбора папки с файлами
  With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "Выберите папку с файлами"
    .ButtonName = "Выбрать"
    .AllowMultiSelect = False
    If .Show Then sDirectoryPath = .SelectedItems(1) Else Exit Sub
  End With
  
  sFileName = Dir(sDirectoryPath & "\*.doc*") 'читаем файлы из папки
  Do While Len(sFileName) > 0 'пока есть имя файла
    'Открываем документ
    Set oDoc = Documents.Open(sDirectoryPath & "\" & sFileName, AddToRecentFiles:=False)
    n = n + 1
    'Перебираем все разделы в документе и задаем текст нижнего и верхнего колонтитулов
    For Each oSec In oDoc.Sections
      oSec.Headers(wdHeaderFooterPrimary).Range.Text = "Верхний колонтитул раздела " & oSec.Index
      oSec.Footers(wdHeaderFooterPrimary).Range.Text = "Нижний колонтитул раздела " & oSec.Index
    Next
    oDoc.Close True 'Закрываем документ
    'Делаем то, что накопилось в системе, чтобы не зависнуть
    DoEvents
    Application.StatusBar = "Обработано " & n & " файлов"
    sFileName = Dir 'Читаем имя следующего файла
  Loop
  'Очищаем мусор
  Set oDoc = Nothing: Set oSec = Nothing: Err.Clear
  'Сообщение о результатах работы
  MsgBox "В каталоге """ & sDirectoryPath & """ обработано " & n & " файлов", vbInformation + vbOKOnly, "Добавление колонтитулов"
End Sub

Спасибо!!!!
Вроде работаеь!!!!!!!!!!

[provodnikam]

Единственная проблемма цикл бесконечный почему-то!!!!!!!!((((((((((((((((((((((

[viter.alex]

Цикл не бесконечный. Всё работает. Если файлов много, то вставлять будет долго. Наберись терпения.

[provodnikam]

А можно ещё спросить:
мне в колонтитуле нужно, что бы содержался текс и ссылка на сайт.
Как ссылочку туду вставить????
Заранее большое спасибо за ответ!!!

[viter.alex]

Ссылочки вставляются добавлением элементов в коллекцию Hyperlinks

Sub InsertHeadersFooters()
  On Error Resume Next
  Dim sDirectoryPath As String 'Путь к каталогу с файлами
  Dim sFileName As String 'Имя файла
  Dim oDoc As Document 'текущий документ
  Dim oSec As Section 'Раздел документа
  Dim n As Long 'Счетчик документов
  Dim oHypRng As Range 'Место для вставки гиперссылки
  Dim sHyperlink As String 'Адрес гиперссылки
  
  'Текст гиперссылки
  sHyperlink = InputBox("Введите адрес для гиперссылки", "Вставка гиперссылки в колонтитул", "http://www.programmersforum.ru/showthread.php?t=71700")
  If Len(sHyperlink) = 0 Then Exit Sub
  
  'Диалог выбора папки с файлами
  With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "Выберите папку с файлами"
    .ButtonName = "Выбрать"
    .AllowMultiSelect = False
    If .Show Then sDirectoryPath = .SelectedItems(1) Else Exit Sub
  End With
  
  sFileName = Dir(sDirectoryPath & "\*.doc*") 'читаем файлы из папки
  Do While Len(sFileName) > 0 'пока есть имя файла
    'Открываем документ
    Set oDoc = Documents.Open(sDirectoryPath & "\" & sFileName, AddToRecentFiles:=False)
    n = n + 1
    'Перебираем все разделы в документе и задаем текст нижнего и верхнего колонтитулов
    For Each oSec In oDoc.Sections
      Set oHypRng = oSec.Headers(wdHeaderFooterPrimary).Range
      oHypRng.Collapse wdCollapseStart
      oSec.Headers(wdHeaderFooterPrimary).Range.Hyperlinks.Add oHypRng, sHyperlink
      oSec.Headers(wdHeaderFooterPrimary).Range.InsertAfter " Верхний колонтитул раздела " & oSec.Index
      oSec.Footers(wdHeaderFooterPrimary).Range.Text = "Нижний колонтитул раздела " & oSec.Index
    Next
    oDoc.Close True 'Закрываем документ
    'Делаем то, что накопилось в системе, чтобы не зависнуть
    DoEvents
    Application.StatusBar = "Обработано " & n & " файлов"
    sFileName = Dir 'Читаем имя следующего файла
  Loop
  'Очищаем мусор
  Set oDoc = Nothing: Set oSec = Nothing: Set oHypRng = Nothing: Err.Clear
  'Сообщение о результатах работы
  MsgBox "В каталоге """ & sDirectoryPath & """ обработано " & n & " файлов", vbInformation + vbOKOnly, "Добавление колонтитулов"
End Sub

[provodnikam]

Благодарю!!!
Всё работает!!!!!