-
Run macro on save
Hi Everyone.
Im new to vba but am trying to work out how to run a macro on save. ive tried searching but cant find out how to apply it to an existing macro.
I want to run a update all fields macro when a doc is saved. Heres the vba for the update fields. Any advice help would really be helpful.
Cheers
Giles
ub UpdateAllFieldsInDocument()
'=========================
'Macro created 2019 by Lene Fredborg, DocTools - www.thedoctools.com
'Revised August 2020 by Lene Fredborg
'THIS MACRO IS COPYRIGHT. YOU ARE WELCOME TO USE THE MACRO BUT YOU MUST KEEP THE LINE ABOVE.
'YOU ARE NOT ALLOWED TO PUBLISH THE MACRO AS YOUR OWN, IN WHOLE OR IN PART.
'=========================
'The macro updates all fields in the activedocument no matter where the fields are found
'Includes fields in headers, footers, footnotes, endnotes, shapes, etc.
'=========================
Dim oDoc As Document
Dim rngStory As Range
Dim oShape As Shape
Dim oShape_2 As Shape
Dim oTOC As TableOfContents
Dim oTOF As TableOfFigures
Dim oTOA As TableOfAuthorities
Dim blnTurnOnTrackRevisions As Boolean
On Error GoTo ErrorHandler
If Documents.Count = 0 Then
MsgBox "No documents are open.", vbOKOnly, "Update All Fields"
Exit Sub
Else
Set oDoc = ActiveDocument
End If
With oDoc
'Stop if document protection prevents full update of fields
If .ProtectionType <> wdNoProtection Then
MsgBox "The document is protected. In order to update all fields, you must first unprotect the document.", _
vbOKOnly + vbInformation, "Update All Fields – Protected Document"
GoTo ExitHere
End If
blnTurnOnTrackRevisions = False
'Show msg if track changes is on
'Let user turn it off to prevent all updated fields marked as revisions
If .TrackRevisions = True Then
If vbYes = MsgBox("Track changes is currently ON. Do you want to turn OFF track changes while updating fields?", _
vbYesNo + vbQuestion, "Turn Off Track Changes?") Then
blnTurnOnTrackRevisions = True
.TrackRevisions = False
End If
End If
End With
'Turn off screen updating for better performance
Application.ScreenUpdating = False
'Prevent alert when updating footnotes/endnotes/comments story
Application.DisplayAlerts = wdAlertsNone
'Iterate through all stories and update fields
For Each rngStory In ActiveDocument.StoryRanges
If Not rngStory Is Nothing Then
'Update fields directly in story
rngStory.Fields.Update
If rngStory.StoryType <> wdMainTextStory Then
'Update fields in shapes and drawing canvases with shapes
For Each oShape In rngStory.ShapeRange
With oShape.TextFrame
If .HasText Then
.TextRange.Fields.Update
End If
'In case of a drawing canvas
'May contain other shapes that may contain fields
If oShape.Type = msoCanvas Then
For Each oShape_2 In oShape.CanvasItems
With oShape_2.TextFrame
If .HasText Then
.TextRange.Fields.Update
End If
End With
Next oShape_2
End If
End With
Next oShape
End If
'Handle e.g. multiple sections with unlinked headers/footers or linked text boxes
If rngStory.StoryType <> wdMainTextStory Then
While Not (rngStory.NextStoryRange Is Nothing)
Set rngStory = rngStory.NextStoryRange
rngStory.Fields.Update
'Update fields in shapes and drawing canvases with shapes
For Each oShape In rngStory.ShapeRange
With oShape.TextFrame
If .HasText Then
.TextRange.Fields.Update
End If
'In case of a drawing canvas
'May contain other shapes that may contain fields
If oShape.Type = msoCanvas Then
For Each oShape_2 In oShape.CanvasItems
With oShape_2.TextFrame
If .HasText Then
.TextRange.Fields.Update
End If
End With
Next oShape_2
End If
End With
Next oShape
Wend
End If
End If
Next rngStory
'=========================
'Update any TOC, TOF, TOA
For Each oTOC In oDoc.TablesOfContents
oTOC.Update
Next oTOC
For Each oTOF In oDoc.TablesOfFigures
oTOF.Update
Next oTOF
For Each oTOA In oDoc.TablesOfAuthorities
oTOA.Update
Next oTOA
'=========================
ExitHere:
On Error Resume Next
'Restore to original track revisions if relevant
If blnTurnOnTrackRevisions = True Then
oDoc.TrackRevisions = True
End If
'Clean up
Set oDoc = Nothing
Set rngStory = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = wdAlertsAll
Exit Sub
'=========================
ErrorHandler:
'Make sure to display alerts again in case of an error
Resume ExitHere
End Sub
-
Finally worked it out. This was really helpful
https://stackoverflow.com/questions/...ds-before-save
heres the finished code if anyone else needs it.
Dim WithEvents TheApp As Word.Application
Private Sub Document_Open()
Set TheApp = ThisDocument.Application
End Sub
Private Sub TheApp_DocumentBeforeSave(ByVal Doc As Document, SaveAsUI As Boolean, Cancel As Boolean)
'=========================
'Macro created 2019 by Lene Fredborg, DocTools - www.thedoctools.com
'Revised August 2020 by Lene Fredborg
'THIS MACRO IS COPYRIGHT. YOU ARE WELCOME TO USE THE MACRO BUT YOU MUST KEEP THE LINE ABOVE.
'YOU ARE NOT ALLOWED TO PUBLISH THE MACRO AS YOUR OWN, IN WHOLE OR IN PART.
'=========================
'The macro updates all fields in the activedocument no matter where the fields are found
'Includes fields in headers, footers, footnotes, endnotes, shapes, etc.
'=========================
Dim oDoc As Document
Dim rngStory As Range
Dim oShape As Shape
Dim oShape_2 As Shape
Dim oTOC As TableOfContents
Dim oTOF As TableOfFigures
Dim oTOA As TableOfAuthorities
Dim blnTurnOnTrackRevisions As Boolean
On Error GoTo ErrorHandler
If Documents.Count = 0 Then
MsgBox "No documents are open.", vbOKOnly, "Update All Fields"
Exit Sub
Else
Set oDoc = ActiveDocument
End If
With oDoc
'Stop if document protection prevents full update of fields
If .ProtectionType <> wdNoProtection Then
MsgBox "The document is protected. In order to update all fields, you must first unprotect the document.", _
vbOKOnly + vbInformation, "Update All Fields – Protected Document"
GoTo ExitHere
End If
blnTurnOnTrackRevisions = False
'Show msg if track changes is on
'Let user turn it off to prevent all updated fields marked as revisions
If .TrackRevisions = True Then
If vbYes = MsgBox("Track changes is currently ON. Do you want to turn OFF track changes while updating fields?", _
vbYesNo + vbQuestion, "Turn Off Track Changes?") Then
blnTurnOnTrackRevisions = True
.TrackRevisions = False
End If
End If
End With
'Turn off screen updating for better performance
Application.ScreenUpdating = False
'Prevent alert when updating footnotes/endnotes/comments story
Application.DisplayAlerts = wdAlertsNone
'Iterate through all stories and update fields
For Each rngStory In ActiveDocument.StoryRanges
If Not rngStory Is Nothing Then
'Update fields directly in story
rngStory.Fields.Update
If rngStory.StoryType <> wdMainTextStory Then
'Update fields in shapes and drawing canvases with shapes
For Each oShape In rngStory.ShapeRange
With oShape.TextFrame
If .HasText Then
.TextRange.Fields.Update
End If
'In case of a drawing canvas
'May contain other shapes that may contain fields
If oShape.Type = msoCanvas Then
For Each oShape_2 In oShape.CanvasItems
With oShape_2.TextFrame
If .HasText Then
.TextRange.Fields.Update
End If
End With
Next oShape_2
End If
End With
Next oShape
End If
'Handle e.g. multiple sections with unlinked headers/footers or linked text boxes
If rngStory.StoryType <> wdMainTextStory Then
While Not (rngStory.NextStoryRange Is Nothing)
Set rngStory = rngStory.NextStoryRange
rngStory.Fields.Update
'Update fields in shapes and drawing canvases with shapes
For Each oShape In rngStory.ShapeRange
With oShape.TextFrame
If .HasText Then
.TextRange.Fields.Update
End If
'In case of a drawing canvas
'May contain other shapes that may contain fields
If oShape.Type = msoCanvas Then
For Each oShape_2 In oShape.CanvasItems
With oShape_2.TextFrame
If .HasText Then
.TextRange.Fields.Update
End If
End With
Next oShape_2
End If
End With
Next oShape
Wend
End If
End If
Next rngStory
'=========================
'Update any TOC, TOF, TOA
For Each oTOC In oDoc.TablesOfContents
oTOC.Update
Next oTOC
For Each oTOF In oDoc.TablesOfFigures
oTOF.Update
Next oTOF
For Each oTOA In oDoc.TablesOfAuthorities
oTOA.Update
Next oTOA
'=========================
ExitHere:
On Error Resume Next
'Restore to original track revisions if relevant
If blnTurnOnTrackRevisions = True Then
oDoc.TrackRevisions = True
End If
'Clean up
Set oDoc = Nothing
Set rngStory = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = wdAlertsAll
Exit Sub
'=========================
ErrorHandler:
'Make sure to display alerts again in case of an error
Resume ExitHere
End Sub
-
Thank you for providing all that information for all our guests. SamT
