-
Notifications
You must be signed in to change notification settings - Fork 3
/
HeadersFooters
260 lines (183 loc) · 9.41 KB
/
HeadersFooters
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
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
Function pfHeaders()
'============================================================================
' Name : pfHeaders
' Author : Erica L Ingram
' Copyright : 2019, A Quo Co.
' Call command: Call pfHeaders
' Description : add sections and headers programmatically (YEP!!!)
'gets heading level and heading text and places it in header
'breaks doc into sections at each different heading
'adds company footer to transcript also
'commented lines aren't necessarily correct code.
'============================================================================
Dim astrHeadings As Variant
Dim rCurrentSection As Range, HdrRange As Range
Dim bFound As Boolean
Dim oWordDoc As New Word.Document, oWordApp As New Word.Application
Dim sFileName As String, sCurrentSection As String, sCurrentHeading As String
Dim intItem As Integer, iCurrentSectionNo As Integer, intLevel As Integer
Dim aStyleList() As String, sStyleName As String
Dim StyleName As Variant, Header As Variant
Dim sListStyle As String
bFound = True
sCourtDatesID = Forms![NewMainMenu]![ProcessJobSubformNMM].Form![JobNumberField]
Debug.Print ("---------------------------------------------")
ReDim aStyleList(1 To 1) As String
Dim x As Integer, z As Integer, k As Integer
Dim oHF As HeaderFooter
Dim iMaxHeadingsCount As Integer
Dim sec As Word.Section
sFileName = "I:\" & sCourtDatesID & "\Generated\" & sCourtDatesID & "-CourtCover.docx"
Set oWordApp = GetObject(, "Word.Application")
If Err <> 0 Then
Set oWordApp = CreateObject("Word.Application")
End If
Set oWordDoc = GetObject(sFileName, "Word.Document")
oWordDoc.Application.Visible = True
With oWordDoc.Application
astrHeadings = oWordDoc.GetCrossReferenceItems(wdRefTypeHeading)
For intItem = LBound(astrHeadings) To UBound(astrHeadings)
sCurrentHeading = astrHeadings(intItem)
intLevel = GetLevel(CStr(astrHeadings(intItem)))
sStyleName = "Heading " & intLevel
Debug.Print ("Heading Level: " & intLevel & ", " & sCurrentHeading)
.Selection.Find.ClearFormatting
.Selection.Find.Replacement.ClearFormatting
.Selection.Goto What:=wdGoToHeading, which:=wdGoToNext, Count:=1
sStyleName = "Heading " & intLevel
'aStyleList(intLevel) = sStyleName
aStyleList(intItem) = sStyleName
sStyleName = "Heading " & intLevel
For Each StyleName In aStyleList
Debug.Print StyleName
Next
ReDim Preserve aStyleList(1 To UBound(aStyleList) + 1) As String
With .Selection.Find
.text = ""
.Replacement.text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
'Ctrl Page up once
.Selection.GoToPrevious wdGoToPage
'page down once
.browser.Next
'press home once
.Selection.HomeKey Unit:=wdLine
'insert continuous section break
'Selection.InsertBreak Type:=wdSectionBreakContinuous
.Selection.Paragraphs(1).Range.InsertBreak Type:=wdSectionBreakContinuous
'.Selection.HeaderFooter.LinkToPrevious = False
.Selection.Find.ClearFormatting
.Selection.Find.Replacement.ClearFormatting
.Selection.Goto What:=wdGoToHeading, which:=wdGoToNext, Count:=1
sStyleName = "Heading " & intLevel
With .Selection.Find
.text = ""
.Replacement.text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Debug.Print ("---------------------------------------------")
Next
intItem = 1
For intItem = 1 To oWordDoc.Sections.Count
'add headers to each section
SendKeys "^{HOME}"
For Each StyleName In aStyleList
For Each sec In oWordDoc.Sections
With sec.Headers(wdHeaderFooterPrimary)
'header formatting
'.Selection.HeaderFooter.LinkToPrevious = False
.LinkToPrevious = False
End With
Next sec
Next StyleName
Next
oWordDoc.Application.Selection.HomeKey Unit:=wdStory
intItem = 2
oWordDoc.Application.Selection.Goto What:=wdGoToHeading, which:=wdGoToNext, Count:=1
'For intItem = 2 To oWordDoc.Sections.Count + 1
Dim iHeadingsNumber As Integer, iSectionNumber As Integer, iSectionIndex As Integer
astrHeadings = oWordDoc.GetCrossReferenceItems(wdRefTypeHeading)
For Each sec In oWordDoc.Sections
iSectionIndex = sec.index
iHeadingsNumber = iSectionIndex - 1
iSectionNumber = iSectionIndex
If iHeadingsNumber > UBound(astrHeadings) Then GoTo NextItem
If iHeadingsNumber = 0 Then iHeadingsNumber = 1
If UBound(astrHeadings) = 0 Then GoTo NextItem
sCurrentHeading = astrHeadings(iHeadingsNumber)
intLevel = GetLevel(CStr(astrHeadings(iHeadingsNumber)))
sStyleName = "Heading " & intLevel
iMaxHeadingsCount = UBound(astrHeadings)
'add headers to each section
If iSectionNumber <= iMaxHeadingsCount + 1 Then
sCurrentHeading = astrHeadings(iHeadingsNumber)
intLevel = GetLevel(CStr(astrHeadings(iHeadingsNumber)))
sStyleName = "Heading " & intLevel
iSectionIndex = sec.index
Debug.Print ("Section Number: " & iSectionIndex & " | " & "Headings Number: " & iHeadingsNumber)
If iSectionNumber = 1 Then GoTo SkipFrontPage
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
With oWordDoc.Application
Selection.TypeText text:="***WORKING COPY***"
Selection.Collapse Direction:=wdCollapseEnd
Selection.TypeParagraph
Selection.InsertCrossReference ReferenceType:="Heading", ReferenceKind:= _
wdContentText, ReferenceItem:=iHeadingsNumber, InsertAsHyperlink:=True, _
IncludePosition:=False, SeparateNumbers:=False, SeparatorString:=" "
If sStyleName = "Heading 2" Then Selection.TypeText text:=" -- WITNESSNAME"
Selection.MoveUp Unit:=wdLine, Count:=1, Extend:=wdExtend
Selection.HomeKey Unit:=wdLine, Extend:=wdExtend
Selection.Find.ClearFormatting
With Selection.Find
.text = ""
.Replacement.text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.style = ActiveDocument.Styles("AQC-Header")
End With
oWordDoc.Application.Selection.Goto What:=wdGoToHeading, which:=wdGoToNext, Count:=2
End If
SkipFrontPage:
With sec
.Footers(wdHeaderFooterPrimary).Range.text = "www.aquoco.co | inquiries@aquoco.co"
.Footers(wdHeaderFooterPrimary).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
End With
Next sec
NextItem:
'Next intItem
End With
oWordDoc.SaveAs2 FileName:=sFileName
oWordDoc.Close
Set oWordApp = Nothing
Set oWordDoc = Nothing
Set rCurrentSection = Nothing
End Function