Consulting

Results 1 to 3 of 3

Thread: Run macro on save

  1. #1
    VBAX Newbie
    Joined
    Jun 2021
    Posts
    2
    Location

    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

  2. #2
    VBAX Newbie
    Joined
    Jun 2021
    Posts
    2
    Location
    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

  3. #3
    Moderator VBAX Sage SamT's Avatar
    Joined
    Oct 2006
    Location
    Near Columbia
    Posts
    7,704
    Location
    Thank you for providing all that information for all our guests. SamT
    I expect the student to do their homework and find all the errrors I leeve in.


    Please take the time to read the Forum FAQ

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •