Vba word вставка закладки

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88

Sub ИСПОЛНИТЕЛЬ()
 
'Верхний колонтитул
    ActiveDocument.ActiveWindow.View.SeekView = wdSeekCurrentPageHeader
    
    'убрать параметр "Как в предыдущем разделе" (отменяется параметр по умолчанию):
    Selection.HeaderFooter.LinkToPrevious = Not Selection.HeaderFooter.LinkToPrevious
    
    'отключаем особый колонтитул для первой страницы:
    ActiveDocument.PageSetup.DifferentFirstPageHeaderFooter = False '[False] [True]
    
    'удалем значения верхнего колонтитула для последующих страниц
    ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
    Selection.WholeStory
    Selection.Delete Unit:=wdCharacter, Count:=1
    ActiveDocument.PageSetup.DifferentFirstPageHeaderFooter = True
    
    'отключаем особые колонтитулы разделов
    For i = 1 To ActiveDocument.Sections.Count
    If i > 1 Then
        Set oRange = ActiveDocument.Sections(i).Range
        ActiveDocument.Sections(i).PageSetup.DifferentFirstPageHeaderFooter = False
    End If
    Next
    
    'вставляем нумерацию последуюзих страниц
    Selection.Sections(1).Headers(3).PageNumbers.Add PageNumberAlignment:=wdAlignPageNumberCenter, FirstPage:=False
        With ActiveDocument.Sections(1).Headers(3).Range    '1 wdHeaderFooterPrimary     все к. кроме первой страницы документа или раздела
            .Font.Name = "TimesNewRoman"
            .Font.Size = 12
            .ParagraphFormat.Alignment = wdAlignParagraphCenter
        End With
    ActiveDocument.ActiveWindow.View.SeekView = wdSeekMainDocume
    
'Нижний колонтитул
    Dim sВсе As String
        sИсп = "Исп.: И.О.Фамилия" & Chr(11)
        sТел = "тел.: +7 (000) 000 - 0000 | 0 - 00" & Chr(11)
        sПочта = "эл.почта: [email]name@site.ru[/email]"
        sВсе = sИсп & sТел & sПочта
    ActiveDocument.ActiveWindow.View.SeekView = wdSeekCurrentPageFooter
    
    'удаляем нижний колонтитул
    ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter
    Selection.WholeStory
    Selection.Delete Unit:=wdCharacter, Count:=1
    
    'переменные
    ActiveDocument.ActiveWindow.View.SeekView = wdSeekCurrentPageFooter
    Dim fld As Field
    Dim myFR As Word.Range
    
    'формула перехода данных на последнюю страницу документа
    Set fld = Selection.Fields.Add(Range:=Selection.Range)
        fld.Code.Text = "IF"
    Set myFR = fld.Code
        myFR.SetRange Start:=fld.Code.End, End:=fld.Code.End
        fld.Code.Fields.Add Range:=myFR, Text:="PAGE"
        myFR.SetRange Start:=fld.Code.End, End:=fld.Code.End
        myFR.Text = "="
        myFR.SetRange Start:=fld.Code.End, End:=fld.Code.End
        fld.Code.Fields.Add Range:=myFR, Text:="NUMPAGES"
        myFR.SetRange Start:=fld.Code.End, End:=fld.Code.End
    
    'вставляем закладку
        myFR.Text = """" & sВсе & """"
        myFR.Bookmarks.Add ("Исполнитель")
        
    'форматирование результата исполнитель
        Word.ActiveDocument.Sections(1).Footers(2).Range.Select    '3 wdHeaderFooterEvenPages   все к. даже на пронумерованных статьях
        With ActiveDocument.Sections(1).Footers(2).Range           '2 wdHeaderFooterFirstPage   первый к. в документе или разделе
            .Font.Name = "TimesNewRoman"                           '1 wdHeaderFooterPrimary     все к. кроме первой страницы документа или раздела
            .Font.Size = 9
            .ParagraphFormat.Alignment = wdAlignParagraphLeft
        End With
        Word.ActiveDocument.Sections(1).Footers(1).Range.Select
        With ActiveDocument.Sections(1).Footers(1).Range
            .Font.Name = "TimesNewRoman"
            .Font.Size = 9
            .ParagraphFormat.Alignment = wdAlignParagraphLeft
        End With
    
    'скрыть/показать формулу кода полей False/True
    ActiveDocument.ActiveWindow.View.ShowFieldCodes = False
    ActiveDocument.ActiveWindow.View.SeekView = wdSeekMainDocume
    Selection.Fields.Update
 
End Sub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21

Sub ПРОВЕРКА_ИСПОЛНИТЕЛЯ()
    
    'проверка исполнителя
    Dim SearchString, SearchChar, MyPos
        fИсп = "Исп.: И.О.Фамилия"
        fТел = "тел.: +7 (000) 000 - 0000 | 0 - 00"
        fПочта = "эл.почта: [email]name@site.ru[/email]"
        Где = ActiveDocument.Bookmarks.Item("Исполнитель").Range
        Что = fИсп ' в архиве нужно будет исправить
 
    Проверяем = InStr(Где, Что)
    If Проверяем > 0 Then
        MsgBox "Исполнитель в документе:" _
           & vbCrLf & "      " & fИсп _
           & vbCrLf & "      " & fТел _
           & vbCrLf & "      " & fПочта, 64
    Else
        MsgBox "Исполнитель в документе и установке программы не соответствуют проверке!", 48
        End If
 
End Sub