I am trying to write a macro that counts and locates TOCs within the document (a routine check rather than for a specific file).
TOCs situated in the document's 'body' are easily accessible (via VBA).
Word also lets users place TOC objects inside of shapes (textboxes), but these do not seem to be accessible via code. Granted, it is not that common to have TOCs placed within shapes, but if it is possible - it should be taken into account.
This makes counting and detecting them unreliable.
The only way I know and intuitively thought of was this:
For Each shp In ActiveDocument.Shapes
iCount = iCount + shp.TextFrame.TextRange.<TableOfContents.Count> <<< no access to TableOfContents
Next shp
What code do I need in order to find those TOCs?
Thank you!
The TablesOfContents collection is only available on a Document object. A TOC in the main body of the document will pick up items in textboxes; a TOC in a textbox will pick up items in the main body of the document. (At least, since Word 2010; there was a time when TOCs in text boxes were not "visible" to a TOC field in the main document body.)
However, the VBA property Document.TablesOfContents does not pick up TOCs in text boxes, only in the main body.
So, it's not possible to directly query the number of TOCs in a text box (or AutoShape - a drawing object). That said...
TOCs are managed in the background by Word using the TOC field code. So it is possible to ascertain the number of TOC fields in a given Range. For example:
Sub GetAllToc()
Dim shp As Word.Shape
Dim tbRange As Range
Dim iCount As Long
Dim fld As Word.Field
Debug.Print "TOCs in main Document body: " & ActiveDocument.TablesOfContents.Count
For Each shp In ActiveDocument.Shapes
If shp.Type = msoTextBox Or shp.Type = msoAutoShape Then
Set tbRange = shp.TextFrame.TextRange
For Each fld In tbRange.Fields
If fld.Type = wdFieldTOC Then
iCount = iCount + 1
End If
Next
End If
Next shp
Debug.Print "TOCs in text boxes: " & iCount
End Sub
Related
I'm trying to create a way for a word document to have certain textfields data to be replaced with other data. In my case, textfields are shown as a part of shapes and the textfields themselves don't have name's to them so I wanted to possibly do it by their shape ID. So for example I have a 5 Textboxes next to each other and say I want to edit the 4th textbox to say something since it's blank without affecting the other textboxes. What would I need to do?
Though Process: Because all the files have the same format, if I can figure out the id of that shape or textbox, I can directly reference that id and change the textfield that way. The text in the field is all random so I can't do a specific find word and replace so that's why I'm trying to do it by id or even just by having it do a count of the number of shapes on the page of a word document.
Tip: I turned on paragraph markers to see the textboxes more clearly.
Example of Code I've written so far:
Sub TextBox()
'find a specific textbox and edit it
Dim doc As word.Document, rng As word.Range
Dim shp As Shape, iShp As word.InlineShape
Set doc = ActiveDocument
Dim textbCount As String
Dim textbId As String
'textbCount = ActiveDocument.Shapes.Count
'textbId = oShape.ID
Dim sr As ShapeRange
Set sr = shp.TextFrame.TextRange.ShapeRange(5)
For Each shp In sr
If shp.ID = 0 Then
'oShape.TextFrame.TextRange.InsertAfter shp.ID
'shp.Delete
Debug.Print shp.Type
Debug.Print shp.ID
End If
Next shp
If ActiveDocument.Shapes.Count > 0 Then
For Each shp In ActiveDocument.Shapes
If shp.AutoShapeType = msoShapeRectangle Then
If shp.TextFrame.HasText = True Then
'shp.TextFrame.TextRange.GoToNext (wdGoToField)
'shp.Delete
'shp.Delete
shp.TextFrame.TextRange.InsertAfter textbCount
Exit For
End If
End If
Next shp
End If
End Sub
This is code you could use, I was able to just figure out the answer. What the code does is checks that the word document that you are trying to read is open and then it first checks to see if there are any shapes at all on the document which is the c > 0 because textboxes are categorized as shapes. Then it does a For Each loop going through all the shapes on the entire document and each shape has it's own unique identifier.
I already tested this for if templates that have the same format of textboxes, they will typically share the same identifier, so if you say have 2 word documents with each 20 textboxes and its a carbon copy of the other just with different text in the boxes almost like they took this blank document and then used it as the base template, it's highly likely that the ID's between the 2 documents are the same if opened separately, if they are combined into 1 document is when the ID's will change so that your not referencing the same data.
To continue on with the code, it will next check all the textboxes for a #, this can be changed out for anything, but for my case I wanted to find out which boxes by their ID I would be using since the word doc won't tell you, so because no where else on the document had #'s, I used those to find where the boxes were. Once you know the ID, you can just reference the boxes directly instead of using the #'s but you need to first know which ones have them.
Next the code will print to the "Immediate Window" which is like a debug window that you can open either in the view tab or by ctrl + G if your one windows and what it will print is the shape ID for each shape that has the # and then print whatever text is in that box which should include the # there along with whatever text is there in that box.
Now if you want to add text to the text box, I didn't include it in my example, or even replace the text. Just make an if statement for if shp.ID = 16 for example then inside that If Then statement say shp.TextFrame.TextRange.Text = "" or if you have a string you want to pass in, replace "" with whatever string that is and in the double quotes you can either leave that blank to make that textbox your referencing blank or you can put text in it to make it say something.
If your doing a project, like I was, and it requires checking a lot of these textboxes to reference the string to another textbox so basically one textbox determines the other. Use For Each shp In oShp a lot or your equivalent to that and check each ID and store it in a string variable and then do a separate For Each to reference those string variables to make new if statements or declarations since you you'll need to go through all the textboxes at least once to grab whatever data might be contained in them since it goes through the For Each sequence one at a time.
Dim shp As Shape
Dim oShp As Object
Dim doc As Document
Dim c As Integer
Dim objWord As Object
Dim objDoc As Document
'Set doc = ActiveDocument
Set objWord = GetObject(, "Word.Application")
objWord.Visible = True
Set objDoc = objWord.Documents.Open("C:\Users\word.docx") 'Set this to wherever the word file is located along with the name of the word file so "C:\Users\worddoc.docx" is an example you could do
'Set objDoc = objWord.ActiveDocument
Set doc = objWord.ActiveDocument
Set oShp = doc.Shapes
c = ActiveDocument.Shapes.Count
'Set text1 = shp.TextFrame.TextRange
If c > 0 Then
For Each shp In oShp
If InStr(shp.TextFrame.TextRange.Text, "#") Then
Debug.Print shp.ID
Debug.Print shp.TextFrame.TextRange.Text
End If
Next shp
Debug.Print c
End If
I've written some code that formats text. The code doesn't work if user has put the cursor in a shape that is part of a group of shapes, the solution for which is to ungroup the shapes.
I want to regroup the shapes after executing the formatting code.
I am able to store the underlying shapes as objects, as well as their names. But, the normal approach to grouping (using shape names) doesn't work, because there can be multiple instances of those shape names on a given slide. E.g. this doesn't work as there could be multiple instances of "textbox" on the slide:
Set TempShapeGroup = TempSlide.Shapes.Range(Array("textbox", "header", "separator")).Group
https://learn.microsoft.com/en-us/office/vba/api/powerpoint.shaperange.group
But, I have the shape objects stored in an array, the crux of which is this (the object 'TempShape' is the group of shapes):
Dim ShapesArray() As Shape
ReDim ShapesArray(1 To TempShape.GroupItems.Count)
For i = 1 To TempShape.GroupItems.Count
Set ShapesArray(i) = TempShape.GroupItems.Item(i)
Next i
So, what I want to do is recreate the group of shapes, using the array of shape objects, so something to the effect of the below would be ideal:
Set MyShapesGroup= ShapesArray.Group
But any way to group shapes using Shape objects would be fine.
TIA
Here's some starter code that you can modify into a function that'll return a reference to the paragraph that contains the current selection cursor. It doesn't really need all the debug.print stuff, of course, but that might help to illustrate the object hierarchy:
Sub WhereIsTheCursor()
Dim oRng As TextRange
Dim oParentRange As TextRange
Dim x As Long
Dim lSelStart As Long
Dim lSelLen As Long
With ActiveWindow.Selection.TextRange
' find the selection start relative to first character in shape
lSelStart = .Start
' lSelLen = .Length
Debug.Print TypeName(.Parent)
Debug.Print TypeName(.Parent.Parent)
Debug.Print TypeName(.Parent.Parent.Parent)
Debug.Print .Paragraphs.Count
Set oRng = .Characters(.Start, .Length)
Debug.Print oRng.Text
' Reference the overall shape's textrange
Set oParentRange = .Parent.Parent.TextFrame.TextRange
' For each paragraph in the range ...
For x = 1 To oParentRange.Paragraphs.Count
' is the start of the selection > the start of the paragraph?
If lSelStart > oParentRange.Paragraphs(x).Start Then
' is the start < the start + length of the paragraph?
If lSelStart < oParentRange.Paragraphs(x).Start _
+ oParentRange.Paragraphs(x).Length Then
' bingo!
MsgBox "The cursor is in paragraph " & CStr(x)
End If
End If
Next
End With
End Sub
Not sure I'm completely understanding the problem, but this may help:
If the user has selected text within a shape, it doesn't really matter whether the shape is part of a group or not. You may need to test the .Selection.Type and handle things differently depending on whether the .Type is text or shaperange. Example:
Sub FormatCurrentText()
If ActiveWindow.Selection.Type = ppSelectionText Then
With ActiveWindow.Selection.TextRange
.Font.Name = "Algerian"
End With
End If
End Sub
I am very new with Powerpoint VBA and would like to know if there is a short way to transfer one text range from PowerPoint A to another text range located in Powerpoint B in a specific sequence.
Page a1 = b1
Page a2 = b2
Page a3 = b3
The template is changing and I need to adapt 5 powerpoints of 100 slides so I tought it would be easier with this solution.
Thank you in advance for your help.
PRECISION : I don't want to copy and paste the text range but to copy the text inside the range to put it inside the new range. Please find below the code I already have but It doesnt' Paste it inside my new range.
Sub copier_texte() 'je veux copier le contenu de la forme, et non pas la forme en entier
Dim nb_slide As Integer
nb_slide = ActivePresentation.Slides.Count
With ActivePresentation
.Slides(1).Shapes(2).TextFrame.TextRange.Copy 'je sélectionne uniquement le contenu de la forme
For i = 2 To .Slides.Count
.Slides(i).Select
ActiveWindow.View.Paste
Next i
End With
End Sub
Short Answer:
Is there're a short way to transfer one text range from PowerPoint A to another text range located in Powerpoint B?
I think that there's no short way to do it, but let's try something first!
Long Answer:
Note: This solution based not on your desired behaviour (since it's unclear for me and there're many and more "what if" cases), but on similar problem, so I think that it's legit. Anyway it's a good fundament to start of.
Input:
I dont know how exactly your presentations looks like, so I made a reference one (Presentation A) and a "broken" one (Presentation B). Let's take a look on them:
Presentation A (5 slides: 1x"Title slide" with 2 triangle shapes, 3x"Title and Content" slides, 1x"Section Header" slide):
Presentation B (5 slides: 1x"Title slide" missing triangle shapes, 3x"Title and Content" slides with empty/without shapes(placeholders), 1x"Blank" slide (wrong layout)):
Both presentations are in the same folder:
Desired behaviour:
Some sort of synchronisation, if we miss a shape - then create one and put desired text to it, if there's one - put desired text only (based on Presentations A's shape). There're some "what if" cases in logic:
"What if" the number of slides in each presentation isn't equal? In which order compare slides then? (In our case the number is equal, so in code we drop that part and compare slides pair by pair).
"What if" the compared slides have a different layout? (In our case difference in blank layout, so we can easily handle it, but what we should do in general?)
...and many other cases not considered in this solution
Logic:
Logic is plain and simple. The entry point to our routine is in the Presentation A, since it's an our reference file. From that point we acquire a reference to Presentation B (when opening it), and start iteration in two loops (thru each pair of slides and thru reference shapes).
If we found a "broken" (or not so, there's no check for that) shape by a reference one - we put text and some options in it or create a new one shape (or placeholder) otherwise.
Option Explicit
Sub Synch()
'define presentations
Dim ReferencePresentation As Presentation
Dim TargetPresentation As Presentation
'define reference objects
Dim ReferenceSlide As Slide
Dim ReferenceSlides As Slides
Dim ReferenceShape As Shape
'define target objects
Dim TargetSlide As Slide
Dim TargetSlides As Slides
Dim TargetShape As Shape
'define other variables
Dim i As Long
'Setting-up presentations and slide collections
Set ReferencePresentation = ActivePresentation
With ReferencePresentation
Set TargetPresentation = Presentations.Open(FileName:=.Path & "/Presentation B.pptm", _
WithWindow:=msoFalse)
Set ReferenceSlides = .Slides
End With
Set TargetSlides = TargetPresentation.Slides
'Check slide count
If ReferenceSlides.Count <> TargetSlides.Count Then
'What's a desired behaviour for this case?
'We can add slides to target presentation but it adds complexity
Debug.Print "ERROR!" & vbTab & "Reference And Target slides counts are not equal!"
Else
'"mainloop" for slides
For i = 1 To ReferenceSlides.Count
Set ReferenceSlide = ReferenceSlides(i)
Set TargetSlide = TargetSlides(i)
'Check slide layout
If ReferenceSlide.Layout <> TargetSlide.Layout Then
'What's a desired behaviourfor this case?
'We can change layout for target presentation but it adds complexity
'But let's try to change a layout too, since we have an easy case in our example!
Debug.Print "WARNING!" & vbTab & "Reference And Target slides layouts are not same!"
TargetSlide.Layout = ReferenceSlide.Layout
End If
'"innerloop" for shapes (for placeholders actually)
With ReferenceSlide
For Each ReferenceShape In .Shapes
Set TargetShape = AcquireShape(ReferenceShape, TargetSlide, True)
If TargetShape Is Nothing Then
Debug.Print "WARNING!" & vbTab & "There's no shape like " & ReferenceShape.Name
ElseIf TargetShape.HasTextFrame Then
With TargetShape.TextFrame.TextRange
'paste text
.Text = ReferenceShape.TextFrame.TextRange.Text
'and options
.Font.Size = ReferenceShape.TextFrame.TextRange.Font.Size
.Font.Name = ReferenceShape.TextFrame.TextRange.Font.Name
.Font.Color.RGB = ReferenceShape.TextFrame.TextRange.Font.Color.RGB
'...
End With
End If
Next
End With
Next
End If
'Save and close target presentation
Call TargetPresentation.Save
Call TargetPresentation.Close
End Sub
Function AcquireShape(ByRef ReferenceShape As Shape, ByRef TargetSlide As Slide, _
Optional ByVal CreateIfNotExists As Boolean) As Shape
Dim TargetShape As Shape
With ReferenceShape
'seek for existed shape
For Each TargetShape In TargetSlide.Shapes
If TargetShape.Width = .Width And TargetShape.Height = .Height And _
TargetShape.Top = .Top And TargetShape.Left = .Left And _
TargetShape.AutoShapeType = .AutoShapeType Then
Set AcquireShape = TargetShape
Exit Function
End If
Next
'create new
If CreateIfNotExists Then
If .Type = msoPlaceholder Then
Set AcquireShape = TargetSlide.Shapes.AddPlaceholder(.PlaceholderFormat.Type, .Left, .Top, .Width, .Height)
Else
Set AcquireShape = TargetSlide.Shapes.AddShape(.AutoShapeType, .Left, .Top, .Width, .Height)
End If
End If
End With
End Function
Output:
I know that it's hard to find any difference by a screenshot (it's can be even photoshoped, anyway there're a few difference for that purpose), but for a full answer, here it is:
Conclusion:
As you see, it isn't a hard task to achieve something similar to your desire, but complexity of solution depends on inputs and on "what if" cases, hence there's no short way to overcome this task in general (in my humble opinion). Cheers!
Your question has a number of different interpretations, below is my attempt to answer what I believe the question is. There are a number of stage to this solution.
1. Ensure we save the VBA we write
Firstly, we have to assume a master presentation, that is one that will hold the values to be copied into all others. This will need to be saved as a macro enabled presentation (pptm) to allow us to save our VBA. This is done via File > Save-As and while selecting the save location choose PowerPoint Macro-Enabled Presentation in the Save as type box.
2. Enable Windows scripting runtime
Within the pptm 'master' presentation that we now have, open the VBA IDE (Alt+F11). In the menu bar select Tools > References... and tick Microsoft Scripting Runtime from the list that is presented. Click OK to close the references dialog box with your tick remembered. This is needed for some error handling in the code, it checks to see if the presentation exists before trying to open it.
3. Insert the provided code
Right-click on VBAProject in the upper right area (the Project explorer) and select Insert > Module.
In the main editing area paste the below (I have added commenting to describe what is happening): -
Option Explicit
Public Sub Update()
Dim AryPresentations(4) As String
Dim LngPID As Long
Dim FSO As New FileSystemObject
Dim PP_Src As Presentation
Dim PP_Dest As Presentation
Dim Sld_Src As Slide
Dim Sld_Dest As Slide
Dim Shp_Src As Shape
Dim Shp_Dest As Shape
Dim LngFilesMissing As Long
Dim BlnWasOpen As Boolean
'If there is an error, this will handle it and stop the process
On Error GoTo ErrorHandle
'Increase the size of AryPresentations and and the paths as shown in the example below
AryPresentations(0) = "C:\Users\garye\Desktop\PP2.pptx"
AryPresentations(1) = "C:\Users\garye\Desktop\PP3.pptx"
AryPresentations(2) = "C:\Users\garye\Desktop\PP4.pptx"
AryPresentations(3) = "C:\Users\garye\Desktop\PP5.pptx"
AryPresentations(4) = "C:\Users\garye\Desktop\PP6.pptx"
'PP_Src is this, our 'master' presentation
Set PP_Src = ActivePresentation
'This loops through each item in AryPresentations
For LngPID = 0 To UBound(AryPresentations, 1)
'We rememeber if you had it open already as if you did, then we won't close it when we are done
BlnWasOpen = False
'Check all currently open presentations to see if one if the presentation we are due to update
For Each PP_Dest In PowerPoint.Presentations
If Trim(UCase(PP_Dest.FullName)) = Trim(UCase(AryPresentations(LngPID))) Then Exit For
Next
'If it was not already open, check it exists and if it does, then open in
If PP_Dest Is Nothing Then
If FSO.FileExists(AryPresentations(LngPID)) Then
Set PP_Dest = PowerPoint.Presentations.Open(AryPresentations(LngPID))
End If
Else
BlnWasOpen = True
End If
If PP_Dest Is Nothing Then
Debug.Print "File note found"
LngFilesMissing = LngFilesMissing + 1
Else
'The below connects to the slide (Sld_Src) you want to pick up from, the shape (Shp_Src) you want to pick up from and then
'places it in the slide (Sld_Dest) you want it to go to into the shape (Shp_Dest) you want it to go in to
Set Sld_Src = PP_Src.Slides(1)
Set Sld_Dest = PP_Dest.Slides(1)
Set Shp_Src = Sld_Src.Shapes(1)
Set Shp_Dest = Sld_Dest.Shapes(1)
Shp_Dest.TextFrame.TextRange.Text = Shp_Src.TextFrame.TextRange.Text
Set Shp_Dest = Nothing
Set Shp_Src = Nothing
Set Sld_Dest = Nothing
Set Sld_Src = Nothing
'Repeat the above for each piece of text to copy
'Finally save the changes
PP_Dest.Save
'Close the presentation if it was not already open
If Not BlnWasOpen Then PP_Dest.Close
End If
Next
MsgBox "Process complete. Number of missing files: " & LngFilesMissing, vbOKOnly + vbInformation, "Complete"
Exit Sub
ErrorHandle:
MsgBox "There was an error: - " & vbNewLine & vbNewLine & Err.Number & ": " & Err.Description, vbOKOnly + vbExclamation, "Error"
Err.Clear
End Sub
4. Customise code
You'll want to add the paths and location of the changes in and then it should run.
I have built - over the years - a vba macro that is supposed to update all fields in a word document.
I invoke this macro before releasing the document for review to ensure all headers and footers etc are correct.
Currently - it look like this:
Sub UpdateAllFields()
'
' UpdateAllFields Macro
'
'
Dim doc As Document ' Pointer to Active Document
Dim wnd As Window ' Pointer to Document's Window
Dim lngMain As Long ' Main Pane Type Holder
Dim lngSplit As Long ' Split Type Holder
Dim lngActPane As Long ' ActivePane Number
Dim rngStory As Range ' Range Objwct for Looping through Stories
Dim TOC As TableOfContents ' Table of Contents Object
Dim TOA As TableOfAuthorities 'Table of Authorities Object
Dim TOF As TableOfFigures 'Table of Figures Object
Dim shp As Shape
' Set Objects
Set doc = ActiveDocument
Set wnd = doc.ActiveWindow
' get Active Pane Number
lngActPane = wnd.ActivePane.Index
' Hold View Type of Main pane
lngMain = wnd.Panes(1).View.Type
' Hold SplitSpecial
lngSplit = wnd.View.SplitSpecial
' Get Rid of any split
wnd.View.SplitSpecial = wdPaneNone
' Set View to Normal
wnd.View.Type = wdNormalView
' Loop through each story in doc to update
For Each rngStory In doc.StoryRanges
If rngStory.StoryType = wdCommentsStory Then
Application.DisplayAlerts = wdAlertsNone
' Update fields
rngStory.Fields.Update
Application.DisplayAlerts = wdAlertsAll
Else
' Update fields
rngStory.Fields.Update
If rngStory.StoryType <> wdMainTextStory Then
While Not (rngStory.NextStoryRange Is Nothing)
Set rngStory = rngStory.NextStoryRange
rngStory.Fields.Update
Wend
End If
End If
Next
For Each shp In doc.Shapes
If shp.Type <> msoPicture Then
With shp.TextFrame
If .HasText Then
shp.TextFrame.TextRange.Fields.Update
End If
End With
End If
Next
' Loop through TOC and update
For Each TOC In doc.TablesOfContents
TOC.Update
Next
' Loop through TOA and update
For Each TOA In doc.TablesOfAuthorities
TOA.Update
Next
' Loop through TOF and update
For Each TOF In doc.TablesOfFigures
TOF.Update
Next
' Header and footer too.
UpdateHeader
UpdateFooter
' Return Split to original state
wnd.View.SplitSpecial = lngSplit
' Return main pane to original state
wnd.Panes(1).View.Type = lngMain
' Active proper pane
wnd.Panes(lngActPane).Activate
' Close and release all pointers
Set wnd = Nothing
Set doc = Nothing
End Sub
Sub UpdateFooter()
Dim i As Integer
'exit if no document is open
If Documents.Count = 0 Then Exit Sub
Application.ScreenUpdating = False
'Get page count
i = ActiveDocument.BuiltInDocumentProperties(14)
If i >= 1 Then 'Update fields in Footer
For Each footer In ActiveDocument.Sections(ActiveDocument.Sections.Count).Footers()
footer.Range.Fields.Update
Next
End If
Application.ScreenUpdating = True
End Sub
'Update only the fields in your footer like:
Sub UpdateHeader()
Dim i As Integer
'exit if no document is open
If Documents.Count = 0 Then Exit Sub
Application.ScreenUpdating = False
'Get page count
i = ActiveDocument.BuiltInDocumentProperties(14)
If i >= 1 Then 'Update fields in Header
For Each header In ActiveDocument.Sections(ActiveDocument.Sections.Count).Headers()
header.Range.Fields.Update
Next
End If
Application.ScreenUpdating = True
End Sub
I have noticed recently that it sometimes misses some sections of the document. Today it missed First page footer -section 2- (the document version was not updated).
I have built this macro over a number of years and several bouts of research but I am not proud of it so please suggest a complete replacement if there is now a clean way of doing it. I am using Word 2007.
To test, create a word document and add a custom field named Version and give it a value. Then use that field {DOCPROPERTY Version \* MERGEFORMAT } in as many places as you can. Headers, Footers, first-page, subsequent page etc. etc. Remember to make a multi-section document with different header/footers. Then change the property and invoke the macro. It currently does quite a good job, handling TOCs and TOAs an TOFs etc, it just seems to skip footers (sometimes) in a multi-section document for example.
Edit
The challenging document that seems to cause the most problems is structured like this:
It has 3 sections.
Section 1 is for the title page and TOC so the first page of that section has no header/footer but does use the Version property on it. Subsequent pages have page numbering in roman numerals for the TOC.
Section 2 is for the body of the document and has headers and footers.
Section 3 is for the copyright blurb and this has a very strange header and a cut-down footer.
All footers contain the Version custom document property.
My code above seems to work in all cases except sometimes it misses first page footer of sections 2 and 3.
For years, the standard I've used for updating all fields (with the exception of TOC, etc. which are handled separately) in a document is the one the Word MVPs use and recommend, which I'll copy here. It comes from Greg Maxey's site: http://gregmaxey.mvps.org/word_tip_pages/word_fields.html. One thing it does that I don't see in your version is update any fields in Shapes (text boxes) in the header/footer.
Public Sub UpdateAllFields()
Dim rngStory As Word.Range
Dim lngJunk As Long
Dim oShp As Shape
lngJunk = ActiveDocument.Sections(1).Headers(1).Range.StoryType
For Each rngStory In ActiveDocument.StoryRanges
'Iterate through all linked stories
Do
On Error Resume Next
rngStory.Fields.Update
Select Case rngStory.StoryType
Case 6, 7, 8, 9, 10, 11
If rngStory.ShapeRange.Count > 0 Then
For Each oShp In rngStory.ShapeRange
If oShp.TextFrame.HasText Then
oShp.TextFrame.TextRange.Fields.Update
End If
Next
End If
Case Else
'Do Nothing
End Select
On Error GoTo 0
'Get next linked story (if any)
Set rngStory = rngStory.NextStoryRange
Loop Until rngStory Is Nothing
Next
End Sub
Some research and experimentation produced the following addition which seems to solve the additional problem of updating the headers/footers in a multi-section document.
Add the following dimensions to the earlier answer:
dim sctn as Word.Section
dim hdft as Word.HeaderFooter
And then, add to the earlier code
for each sctn in doc.Sections
for each hdft in sctn.Headers
hdft.Range.Fields.Update
next
for each hdft in sctn.Footers
hdft.Range.Fields.Update
next
next
However - I am still not happy with this code and would very much like to replace it with something less hacky.
Thanks for these answers! I found the answers very good and learned some stuff about ms-word macros. I thought I'd make my own answer for consideration (and adding some more search engine keywords - my searches didn't bring me here immediately).
I took inspiration from the citations in the footnotes.
I had an issue where MS Word fields were not updating in Textbox (Shapes).
I was working on a 70 page word document (Word 2013) that contained a lot of figures/images/captions and cross-references. A common practice is for an image to be captioned e.g. Figure 7, so it can be easily cross-referenced. Often the caption is inside a textbox (shape) and grouped with/to the object its captioning.
So after some document editing and content reorganisation, the fields and cross-references can easily get out of logical sequence.
OK - no problem... pressing CTRL+A then F9 to update the document fields should solve this?
Unfortunately that didn't work as expected to update fields in textboxes (shapes).
In this scenario where fields exist inside textboxes (shapes) CTRL+A then F9 only updated the fields not inside a textbox (shape).
One can assume this behaviour is because field updating (F9) works on selected text, and with the CTRL+A then F9 approach only text outside of the textboxes (shapes) is selected, so the field update only applies outside of textboxes (shapes).
I'm surprised there is not a button on the ribbon to perform an "update all fields". There could even be a toggle option to prompt the user to update all fields when closing a document?
I checked Word's (2013) ribbon command list, and didn't find an Update All command.
Solution UpdateAllFields()
Like the code shared by #Cindy here, the following code should update fields wherever they are in the doc, header, footer, main doc, textbox, grouped and nested grouped textbox.
Create a macro with the following code, and then add to the Quick Access Toolbar (QAT)
Press ALT+F8 to open the Macros dialogue.
Enter a name for the Macro: UpdateAllFields
Press Create button
Paste the code:
Sub UpdateAllFields()
Application.ScreenUpdating = False
With ActiveDocument
.Fields.Update
.PrintPreview
.ClosePrintPreview
End With
Application.ScreenUpdating = True
End Sub
Finally add the Macro to the Quick Access Toolbar.
Citations and inspirations:
The Q&A's in this post!
There is a related post on the Microsoft Community here: Word 365 Fields not updating in Textbox [serious reproducible error]. This suggests the issue is present in at least Word 2013 and Word 365.
There is a related post on Stack Overflow here: Macro to update fields in shapes (textboxes) in footer in Microsoft Word.
Another example UpdateTextboxFields()
This was the first version of code I wrote as I was in research and solution mode. Its a recursive approach to update fields inside textboxes, even if they are inside a group, or nested group. This doesn't update fields outside shapes.
Public Sub UpdateTextboxFields()
Application.ScreenUpdating = False
With ActiveDocument
Call IterateShapesCollection(.Shapes)
.PrintPreview
.ClosePrintPreview
End With
Application.ScreenUpdating = True
End Sub
Private Sub IterateShapesCollection(col)
Dim shp As Shape
For Each shp In col
' https://learn.microsoft.com/en-gb/office/vba/api/office.msoshapetype
' Ignore images and
If 1 = shp.Type Or 13 = shp.Type Then
GoTo NextIteration
End If
'Debug.Print ("Name: " & shp.Name & ", Type: " & shp.Type)
' if the type is a group, recurse
If 6 = shp.Type Then
Call IterateShapesCollection(shp.GroupItems)
Else
Call UpdateShapeFields(shp)
End If
NextIteration:
Next
End Sub
Private Sub UpdateShapeFields(shp)
With shp.TextFrame
If .HasText Then
.TextRange.Fields.Update
End If
End With
End Sub
Word display option: Update fields before printing
cite: Microsoft article Some fields are updated while other fields are not
The concept behind this option/approach is: all document fields are updated when you open print preview.
It looks like this option in Word (tested in 2013) updates all fields with a caveat - see below - you may need to open and close print preview twice.
File → Options → Display → Print options section → Update fields before printing
Caveat if the doc has cross-references to figures/captions
This caveat applies to the word "Update fields before printing" display option and the UpdateAllFields() macro.
IF the document contains cross-references to figures/captions (with numbers), and those figures/captions have changed sequence/place in the document...
You must update the fields twice, 1) to reflect the figures/captions update, and then 2) to update the cross-references.
In the Powerpoint VBA editor, we get a list of slides in the VBA project window, categorised under "Microsoft PowerPoint Objects". This list will include slides that have ActiveX controls on them.
The slides appear with numbers on them ("Slide1", "Slide3", etc), and these numbers look like they are based on the order in which the slides were added to the presentation - not the actual order of the slides in the current presentation. However, the title or name of the slides is not included. This makes it confusing to work with, and difficult to find the slide that has the control one wants to work with.
In Excel VBA, the layout of the editor is the same, with a list of worksheets. However, in Excel the name of the sheet is shown in brackets after the sheet number. So if Sheet1 is called "MyDataSheet", it will show up as "Sheet1 (MyDataSheet)".
How can I achieve something similar in Powerpoint? Is there are way to control the name/title that is used to display each slide in the Powerpoint editor?
This is one of the oddities of the PPT object model. Each slide has an internal name that's assigned by PPT at the time the slide is created. That's what you see in the IDE. Each slide also has a .Name property that's initially the same as the slide name assigned by PPT, but that you can change programmatically.
PPT still shows the assigned name under "Microsoft PowerPoint Objects" but if you look at the Properties window of the IDE (press F4 to display it) you'll see (and can edit) the slide's .Name property. This would let you know which slide you've selected in the IDE.
You could also run a bit of code to change the .Name property in a way that reflect's the slide order:
Sub Thing()
Dim oSl As Slide
For Each oSl In ActivePresentation.Slides
oSl.Name = "SLIDE_" & CStr(oSl.SlideIndex)
Next
End Sub
If you want to get a bit fancier, you can have it pick up the slide's title (if any) as the .Name and use SLIDE_index as the .Name if not:
Sub Thing()
Dim oSl As Slide
Dim sTemp As String
For Each oSl In ActivePresentation.Slides
sTemp = SlideTitle(oSl)
If Len(sTemp) > 0 Then
oSl.Name = oSl.Shapes.Title.TextFrame.TextRange.Text
Else
oSl.Name = "SLIDE_" & CStr(oSl.SlideIndex)
End If
Next
End Sub
Function SlideTitle(oSl As Slide) As String
On Error GoTo ErrHandler
SlideTitle = oSl.Shapes.Title.TextFrame.TextRange.Text
NormalExit:
Exit Function
ErrHandler:
SlideTitle = ""
GoTo NormalExit
End Function
One thing to be careful of here is that PPT may or may not complain if you try to give two slides the same .Name property. In other words, you may want to make sure that your slide titles are unique. There might be other issues (characters that aren't allowed in .Name for example).