Inserting a table of contents on page 2 - vba

I need to create a table of contents that exists at the top of page 2. In my code, I am importing a custom Title page (a building block) and also have to create the Table of Contents based on text in the document. The table of contents works/runs perfectly, it's just in the wrong location.
Sub TitlePage()
Application.Templates( _
mypath). _
BuildingBlockEntries("BuildingBlockName").Insert Where:=Selection.Range, RichText:=True
End Sub
Sub ToC()
Selection.GoTo what:=wdGoToLine, Which:=wdGoToAbsolute
Selection.EscapeKey
Selection.Range.InsertBreak
Selection.GoTo what:=wdGoToPage, Which:=wdGoToNext
Selection.EscapeKey
ActiveDocument.TablesOfContents.Add Range:=Selection.Range, RightAlignPageNumbers:= _
True, UseHeadingStyles:=True, IncludePageNumbers:=True, _
UseHyperlinks:=True, HidePageNumbersInWeb _
:=True, UseOutlineLevels:=False
End Sub
As you can see, these are two different macros that are part of a larger macro. I am using a call function in the main portion of the code to keep things organized. Is there a way to finagle the Table of contents onto page 2?
P.S. I know I've committed the sin of using the selection property. This was to navigate to the first line, then to the second page, then to escape the selection, and insert the ToC where the cursor was last.
I'm desperate.

How about something based on:
Sub ToCAndTitle()
With ActiveDocument
'Insert a Section break before existing content
.Range(0, 0).InsertBreak Type:=wdSectionBreakNextPage
.TablesOfContents.Add Range:=.Range(0, 0), RightAlignPageNumbers:=True, _
UseHeadingStyles:=True, IncludePageNumbers:=True, UseHyperlinks:=True, _
HidePageNumbersInWeb:=True, UseOutlineLevels:=False
'Insert a page break before existing content
.Range(0, 0).InsertBreak Type:=wdPageBreak
Application.Templates(mypath).BuildingBlockEntries("BuildingBlockName").Insert Where:=.Range(0, 0), RichText:=True
End With
End Sub
Inserting a Section break allows the page numbering to start after the TOC, if that's what you want.

Related

Only display outline level 1 text and TC field with outline level 2 in TOC

I'm working with many similar documents given to me, which contains wdStyleHeading1 and 4-5 wdStyleHeading2 below each heading 1. Below each wdStyleHeading1 is a title which I would like to display in the TOC, so it looks like TOC example.
I add this title to the TOC as a TC field with ActiveDocument.TablesOfContents.MarkEntry Range:=Selection.Range, Entry:="TitleSample", Level:=1 for each wdStyleHEading1 which I encounter in my loop.
I create my TOC with the following code:
With ActiveDocument
.TablesOfContents.Add Range:=Selection.Range, _
RightAlignPageNumbers:=True, _
UseHeadingStyles:=True, _
UpperHeadingLevel:=1, _
LowerHeadingLevel:=2, _
UseFields:=True, _
IncludePageNumbers:=True, _
AddedStyles:="", _
UseHyperlinks:=True, _
HidePageNumbersInWeb:=True, _
UseOutlineLevels:=True
.TablesOfContents(1).TabLeader = wdTabLeaderDots
.TablesOfContents.Format = wdIndexIndent
End With
However, I'm at a loss to how I can avoid displaying the 4-5 wdStyleHeading2 in the TOC, while still displaying the TC field titles I added with the MarkEntry method. I have attempted to use Paragraph.OutlineDemote method, but this fails since the document only contains wdOutlineLevel1 and wdOutlineLevel2.
Would the simplest fix be, to just create a style/formatting similar to wdStyleHeading2 which does not contain an outline level and apply this to all paragraphs which have the `wdStyleHeading2, or is there a way where I can keep the default style and omit it from the TOC?
And a bonus question: Is there a way to omit the TabLeader and page numbering for the outline level 1 entries and not outline 1 entries?

Locking a table using VBA macro

I have made a table which auto fills using a user form. Currently, you can add new rows and edit the text within the table. I want to be able to lock the table so that you cannot edit the table at all unless you enter it through the user form. I tried the code:
Private Sub Lock_Table()
Dim NewArea As Table
Set NewArea = ActiveDocument.Tables(1)
NewArea.Locked = True
End Sub
But that came back with the error "method or data member not found"
any help would be appreciated
Thanks!
The following code will insert a table inside a new Rich Text Content Control.
Selection.Range.ContentControls.Add (wdContentControlRichText)
ActiveDocument.Tables.Add Range:=Selection.Range, NumRows:=2, NumColumns:= _
2, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:= _
wdAutoFitFixed
That is from a recorded macro and certainly could be improved to not use the selection object. It gives a 2x2 table inside a rich text content control.
The following locks the first content control in a document.
ActiveDocument.ContentControls(1).Range _
.LockContents = True
That cannot be edited. Obviously, you would change this to False before editing in your userform.

Making links to Places in this document work in vba

I'm trying to make a VBA script that will take all the headings in a document and make a table of contents out of them, with hyperlinks to each of the headings. The headings are all found, parsed and all the hyperlinks are made, however they don't correctly reach their destination which is a place within the document. The default 'create hyperlink to Place in this document' code looks like this:
Selection.Range.Hyperlinks(1).Range.Fields(1).Result.Select
Selection.Range.Hyperlinks(1).Delete
ActiveDocument.Hyperlinks.Add Anchor:=Selection.Range, Address:="", _
SubAddress:="_Test_Heading"
Selection.Collapse Direction:=wdCollapseEnd
This is the code that you would get if you recorded a macro while using the 'Edit hyperlink' window.
Edit hyperlink window
The address field where normally there would be a URL is empty, while the subaddress field is filled by the name of the header with underscores.
I think the problem is that Word defaults to 'Existing file or web page' rather than 'Place in this document', even if 'Place in this document' were specified prior. If I switch the mode of a link to 'Place in this document' without changing the subaddress or anything else, it works - but having to go and do that for each link defeats the purpose of the script. I've been looking all over for a way to express 'Place in this document' in VBA but haven't found anything. Tried bookmarks as an alternative and that didn't work either. Any help would be appreciated.
I found a workaround using cross-referencing. In case it helps anyone in the future:
Private Function GetLevel(strItem As String) As Integer
Dim strTemp As String
Dim strOriginal As String
Dim longDiff As Integer
strOriginal = RTrim$(strItem)
strTemp = LTrim$(strOriginal)
longDiff = Len(strOriginal) - Len(strTemp)
GetLevel = (longDiff / 2) + 1
End Function
Sub TableofContents()
Dim i As Integer
Dim AllHeadings As Variant
AllHeadings = ActiveDocument.GetCrossReferenceItems(wdRefTypeHeading)
Selection.HomeKey Unit:=wdStory
Selection.HomeKey Unit:=wdLine
For i = LBound(AllHeadings) To UBound(AllHeadings)
strtext = Trim$(AllHeadings(i))
Level = GetLevel(CStr(AllHeadings(i)))
If Level = 2 Then
Selection.InsertCrossReference ReferenceType:="Heading", ReferenceKind:= _
wdContentText, ReferenceItem:=i, InsertAsHyperlink:=True, _
IncludePosition:=False, SeparateNumbers:=False, SeparatorString:=" "
Selection.TypeParagraph
End If
Next
End sub
The first function gets the level of the heading.
The second part moves to the top of the document and starts inserting cross-references to the headings that I want (in this case I want it to be = 2).

Add page numbers to the bottom of Word document in the format X of Y

I am trying to add the X of Y page numbers to the bottom right of a Word document. X being the current page number and Y being the total number of pages in the document.
I recorded a macro.
Sub InsertPageLabelsXofY()
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 = wdSeekCurrentPageFooter
Application.Templates( _
"C:\Users\jhandler\AppData\Roaming\Microsoft\Document Building Blocks\1033\16\Built-In Building Blocks.dotx" _
).BuildingBlockEntries("Bold Numbers 3").Insert Where:=Selection.Range, _
RichText:=True
ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
End Sub
This works initially, but after a day or so it gives me an error.
Run-time error '5941': The requested member of the collection does not exist
The line that generates the error is:
Application.Templates( _
"C:\Users\jhandler\AppData\Roaming\Microsoft\Document Building Blocks\1033\16\Built-In Building Blocks.dotx" _
).BuildingBlockEntries("Bold Numbers 3").Insert Where:=Selection.Range, _
RichText:=True
Also, I would like for other people to use the macro. Is there some way to save the template in a public area?
The built-in building blocks template is only loaded on demand, i.e. when a building-block it contains is inserted, as per the documentation. You can force it to load by adding the following line to your routine before you attempt to insert:
Application.Templates.LoadBuildingBlocks
However, if you take the advice offered by #CindyMeister (and you should) you will not need to do this as the template containing your code will already by loaded. You could then rewrite your routine as follows, avoiding the need to open and close the footer:
Sub InsertPageLabelsXofY()
Dim sectionNumber As Long
sectionNumber = Selection.Information(wdActiveEndSectionNumber)
Dim footer As Range
Set footer = ActiveDocument.Sections(sectionNumber).Footers(wdHeaderFooterPrimary).Range
Dim tmp As Template
Set tmp = ActiveDocument.AttachedTemplate
tmp.BuildingBlockEntries("Bold Numbers 3").Insert Where:=footer, RichText:=True
End Sub
To make your routine work, change the "Application.Templates ..." line to:
Templates(1).BuildingBlockEntries("Bold Numbers 3").Insert Selection.Range, True
Word's building blocks template is always available as a global template, and the Built-in version is always the first template, so it has an index of 1.
Trying to specify the path to this template is what is causing the error. Yes, it might work sometimes but at other times it doesn't, so it is best to just use the index level and it has the added benefit of allowing your code to be transportable to other systems. If you tried to execute your existing code on a system that does not have your Home directory, "handler" then it will fail.
Sub AddPageXofYtext()
Dim pageNumber, TotalPage As Long
TotalPage = Selection.Information(wdNumberOfPagesInDocument)
ActiveDocument.Styles("Header").ParagraphFormat.Alignment = wdAlignParagraphRight
Selection.Sections.Item(1).Headers(wdHeaderFooterPrimary).Range.Text = "Page " & Selection.Information(wdActiveEndAdjustedPageNumber) & " of " & TotalPage
pageNumber = 1
Do
Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext, Count:=pageN
Selection.InsertBreak Type:=wdSectionBreakContinuous
Selection.Sections.Item(1).Headers(wdHeaderFooterPrimary).LinkToPrevious = False
Selection.Sections.Item(1).Headers(wdHeaderFooterPrimary).Range.Text = "Page " & Selection.Information(wdActiveEndAdjustedPageNumber) & " of " & TotalPage
pageNumber = pageNumber + 1
If pageNumber = TotalPage Then Exit Do
Loop
End Sub

Select a VBA Pasted Shape from Excel to Word so I can wrap text tight

I'm developing a spreadsheet to automatically generate quotes; this involves copying the correct diagram (a grouped Excel shape) from a sheet with a library of our possible diagrams, and pasting/inserting/[whatever will work best] that image into the VBA-assembled Word document.
So far, I am able to successfully identify, copy and paste special the correct diagram shape from Excel into Word. However, every technique I have found means that the shape either wraps text as inline or infront-- whereas I need the next portion of text to be directly aside the diagram-- thus "wdTight"
Below, you can see how I paste in the current shape. But I can't figure out how to make that shape into ".wrapFormat.Type = wdTight"
I am generally met with a series of Runtime 438 errors: object doesn't support this property or method.
I have a theory that this is because Word considers the selection to always be the blinking text cursor, and not the just pasted shape which is activated and has a hovering layout options tooltip (but that is just a theory).
Here is the code. Please help.
Sub export_excel_to_word()
Dim appWord
Dim quoteWord
Dim wordSelection
Set appWord = CreateObject("Word.Application")
appWord.Visible = True
Set quoteWord = appWord.Documents.Add
Set wordSelection = appWord.Selection
'This part works
Module1.ImagesRefresh
'Product 1 image insertion
Sheets("Quick Lookup").Shapes("QuoteProduct1Image").Copy
wordSelection.PasteSpecial Link:=False, _
DataType:=wdPasteShape, _
Placement:=wdInLine, _
DisplayAsIcon:=False
'This part does not work and is where I need help
With wordSelection
.WrapFormat.Type = wdWrapFront
End With
Try creating a variable to represent the newly pasted shape, it should be accessible by index, and should be the last index:
'Product 1 image insertion
ActiveSheet.Shapes(1).Copy
wordSelection.PasteSpecial Link:=False, _
DataType:=wdPasteShape, _
Placement:=wdInLine, _
DisplayAsIcon:=False
Dim wdShape As Word.Shape
Set wdShape = quoteWord.Shapes(quoteWord.Shapes.Count)
wdShape.WrapFormat.Type = wdWrapTight
Without using the shape variable, this might also work, but I have not tested against a document with several shapes (assuming you're adding shapes in sequence/iteration)
'Product 1 image insertion
ActiveSheet.Shapes(1).Copy
wordSelection.PasteSpecial Link:=False, _
DataType:=wdPasteShape, _
Placement:=wdInLine, _
DisplayAsIcon:=False
wordSelection.ShapeRange(1).WrapFormat.Type = wdWrapTight
If you're also inserting text (e.g., through the TypeText method of a Word.Range, try the code below. I'm not super-familar with Word automation, and the rule that you should avoid activate/select I think is less strict in Word (or has more exceptions) but as a rule of thumb, I'd still try to avoid reliance on the Selection object, and work with ranges instead.
What I'm doing here is pasting to the wordSelection.Range rather than the Selection itself. Then I do
ActiveSheet.Shapes(1).Copy
wordSelection.Range.PasteSpecial Link:=False, _
DataType:=wdPasteShape, _
Placement:=wdInLine, _
DisplayAsIcon:=False
Dim wdShape As Word.Shape
Set wdShape = quoteWord.Shapes(quoteWord.Shapes.Count)
wdShape.WrapFormat.Type = wdWrapTight
wordSelection.TypeText "some text"