Landscape Pages Alt
Public Sub InsertLandscape_Alt(ATName As String, _
Optional AppDiffHead As Boolean, _
Optional AppNoPgNo As Boolean, _
Optional bUpdateHeaderFooter As Boolean)
Dim currsec As Long
Dim LandsSec As Long
Dim AppSec As Long
Dim rgAppHead As Range
Dim selInApp As Boolean
Dim ofld As Field
currsec = Selection.Information(wdActiveEndSectionNumber) 'get the current section number
CheckTrackingON (False)
Application.ScreenUpdating = False
'we are at the beginning of the paragraph (A_code does that) check what's before and after
'mark the current position
ActiveDocument.Bookmarks.Add Name:="BM_CurrPos", Range:=Selection.Range
'go around 20 lines up if needed to find empty paragraph markers (and delete them)
For i = 1 To 20
'check para before
Selection.MoveUp unit:=wdParagraph, Count:=1
'empty pararaph marker delete and go further up
If Selection.Paragraphs(1).Range.text = Chr(13) Then
i = i + 1
Selection.Paragraphs(1).Range.Delete
ElseIf InStr(Selection.Paragraphs(1).Range.text, Chr(12)) Then
'manual pagebreak - if we insert a section break now, they end up with an empty white page
'unfortunately, this also kicks in for a section break!
'go to the end of the para and delete the page break
Selection.SetRange _
Start:=Selection.Paragraphs(1).Range.End - 2, _
End:=Selection.Paragraphs(1).Range.End - 1
On Error Resume Next
'this could be one of our section breaks
Selection.Range.Delete
Err.Clear
On Error GoTo 0
ActiveDocument.Bookmarks("BM_CurrPos").Select
ActiveDocument.Bookmarks("BM_CurrPos").Delete
Exit For
Else
ActiveDocument.Bookmarks("BM_CurrPos").Select
ActiveDocument.Bookmarks("BM_CurrPos").Delete
Exit For
End If
Next i
'we are now at the start of a paragraph insert the section break necessary for the Landscape page
Selection.InsertBreak (wdSectionBreakNextPage)
'get the section number
LandsSec = Selection.Information(wdActiveEndSectionNumber)
'make the new section not first page different
If ActiveDocument.Sections(currsec).PageSetup.DifferentFirstPageHeaderFooter = True Then
ActiveDocument.Sections(LandsSec).PageSetup.DifferentFirstPageHeaderFooter = False
End If
With ActiveDocument.Sections(LandsSec)
.Headers(wdHeaderFooterPrimary).LinkToPrevious = False
.Footers(wdHeaderFooterPrimary).LinkToPrevious = False
End With
'have to do this again for some reason
ActiveDocument.Sections(LandsSec).Headers(wdHeaderFooterPrimary).LinkToPrevious = False
'continue the page numbering
ActiveDocument.Sections(LandsSec).Footers(wdHeaderFooterPrimary).PageNumbers.RestartNumberingAtSection = False
'footers seems to work even if the page number is in the header
'Unlink even pages if the page setup is setup with Odd and Even Page setup
If ActiveDocument.Sections(currsec).PageSetup.OddAndEvenPagesHeaderFooter = True Then
ActiveDocument.Sections(LandsSec).Footers(wdHeaderFooterEvenPages).LinkToPrevious = False
ActiveDocument.Sections(LandsSec).Headers(wdHeaderFooterEvenPages).LinkToPrevious = False
ActiveDocument.Sections(LandsSec).Footers(wdHeaderFooterEvenPages).PageNumbers.RestartNumberingAtSection = False
End If
'Lock the section break
ActiveDocument.Bookmarks.Add ("CurrSel") 'mark the insertion point
'go after the section break and highlight it
Selection.MoveLeft unit:=wdCharacter, Count:=1
'this will insert BEFORE THE SECTION BREAK in 2013
Selection.Range.ContentControls.Add (wdContentControlRichText)
'go after the section break and highlight it
Selection.MoveRight unit:=wdCharacter, Count:=2, Extend:=wdExtend
'the one that's just been inserted
With Selection.ContentControls(1)
.SetPlaceholderText , , text:=" "
.LockContentControl = True
.LockContents = True
.Title = "Locked Section Break"
End With
ActiveDocument.Bookmarks("CurrSel").Select
ActiveDocument.Bookmarks("CurrSel").Delete
'insert the Landscape autotext (this must have a locked section break after) only has the section break after
ActiveDocument.AttachedTemplate.AutoTextEntries(ATName).Insert _
Where:=Selection.Range, RichText:=True
'at this stage, if we have empty paramarkers, delete them
For i = 1 To 20
If Selection.Paragraphs(1).Range.text = Chr(13) And _
Selection.Paragraphs(1).ID <> ActiveDocument.Range.Paragraphs(ActiveDocument.Range.Paragraphs.Count).ID Then
'empty paragraph marker delete and go further up
If Selection.Paragraphs(1).Range.Next(unit:=wdParagraph, Count:=1).Information(wdWithInTable) = False Then
Selection.Paragraphs(1).Range.Delete
Else
Exit For
End If
Else
Exit For
End If
Next i
'update the fields in the new appendix header/footer
ActiveDocument.Sections(LandsSec).Headers(wdHeaderFooterPrimary).Range.Fields.Update
ActiveDocument.Sections(LandsSec).Footers(wdHeaderFooterPrimary).Range.Fields.Update
'we also need to update the header/footer in the rotated one (this has a shape, would be good if we could name it but this works too).
Dim oshp As Shape
For Each oshp In ActiveDocument.Sections(LandsSec).Headers(wdHeaderFooterPrimary).Range.ShapeRange
'in case there are lines or other shapes in there.
On Error Resume Next
oshp.TextFrame.ContainingRange.Fields.Update
Err.Clear
On Error GoTo 0
Next oshp
'This is for a landscape that requires a different header/footer entry (i.e. different style reference field)
If AppDiffHead = True Then
'Find out whether we are in the Appendices
If ActiveDocument.Bookmarks.Exists("BM_SecBreakApp") = True Then
AppSec = ActiveDocument.Bookmarks("BM_SecBreakApp").Range.Information(wdActiveEndSectionNumber) + 1
'and if so insert the correct appendices header into the landscape header
If LandsSec > AppSec Then
Set rgAppHead = ActiveDocument.Sections(AppSec).Headers(wdHeaderFooterPrimary).Range.Bookmarks("BM_LsHeader").Range
'delete what's in there
rgAppHead.text = ""
'go to the first insertion point
rgAppHead.Collapse
ActiveDocument.AttachedTemplate.AutoTextEntries("AT_AppHeader").Insert _
'insert the new field
Where:=ActiveDocument.Sections(LandsSec).Headers(wdHeaderFooterPrimary).Range.Bookmarks("BM_LsHeader").Range, _
RichText:=True
Set rgAppHead = Nothing
End If
End If
If ActiveDocument.Bookmarks.Exists("BM_LsHeader") Then
ActiveDocument.Bookmarks("BM_LsHeader").Delete 'make sure it's gone
End If
End If
'This is for a landscape without page number in the appendices
'Find out whether we are in the Appendices
If AppNoPgNo = True Then
'find out whether we are in the appendices
selInApp = IsSelectionInAppendix
If selInApp = True Then
'go into the header and footer of the new landscape page and delete the page number
For Each ofld In ActiveDocument.Sections(LandsSec).Footers(wdHeaderFooterPrimary).Range.Fields
If ofld.Type = wdFieldPage Then
ofld.Result.Cells(1).Range.Delete
GoTo ContinueNoPgNumber 'found it
End If
Next ofld
For Each ofld In ActiveDocument.Sections(LandsSec).Headers(wdHeaderFooterPrimary).Range.Fields
If ofld.Type = wdFieldPage Then
ofld.Result.Cells(1).Range.Delete
GoTo ContinueNoPgNumber 'found it
End If
Next ofld
'For Portrait Landscape page
For Each ofld In ActiveDocument.Sections(LandsSec).Headers(wdHeaderFooterPrimary).Range.ShapeRange(1).TextFrame.TextRange.Fields
If ofld.Type = wdFieldPage Then
ofld.Result.Cells(1).Range.Delete
GoTo ContinueNoPgNumber 'found it
End If
Next ofld
End If
End If
ContinueNoPgNumber:
If TrackWasON = True Then
ActiveDocument.TrackRevisions = True
End If
If ActiveDocument.Bookmarks.Exists("BM_LandscapeHere") Then
ActiveDocument.Bookmarks("BM_LandscapeHere").Select
End If
Application.ScreenUpdating = True
End Sub
© 2024 Better Solutions Limited. All Rights Reserved. © 2024 Better Solutions Limited TopPrevNext