Microsoft Office Forums

Go Back   Microsoft Office Forums > >

Reply
 
Thread Tools Display Modes
  #1  
Old 10-05-2016, 01:29 AM
Mike_Lennox Mike_Lennox is offline Macro for inserting and formatting headers and footers Windows 10 Macro for inserting and formatting headers and footers Office 2016
Novice
Macro for inserting and formatting headers and footers
 
Join Date: Oct 2016
Posts: 3
Mike_Lennox is on a distinguished road
Default Macro for inserting and formatting headers and footers

Dear All,

I am struggling to finalise a word macro that will:

- open multiple files (check)
- delete all existing headers and footers (check)
- insert new graphics into headers and footers (check)
- Adjust size of graphics - MISSING
- Adjust formatting such as indentation, alignment etc of headers and footers - MISSING

I will also attach a example file of how the final result should look like and one for which these changes will have to be made. And the images.

Would be absolutely great if you guys could help on this. I am really struggling

Here is what I have so far:


Private Sub CommandButton3_Click()


Dim MyDialog As FileDialog, GetStr(1 To 100) As String
Dim oSec As Section
Dim oHead As HeaderFooter
Dim oFoot As HeaderFooter
On Error Resume Next
Set MyDialog = Application.FileDialog(msoFileDialogFilePicker)
With MyDialog
.Filters.Clear
.Filters.Add "All WORD File ", "*.docx", 1
.AllowMultiSelect = True
I = 1
If .Show = -1 Then
For Each stiSelectedItem In .SelectedItems
GetStr(I) = stiSelectedItem
I = I + 1
Next
I = I - 1
End If
Application.ScreenUpdating = False
For j = 1 To I Step 1
Set Doc = Documents.Open(FileName:=GetStr(j), Visible:=True)
Windows(GetStr(j)).Activate
For Each oSec In ActiveDocument.Sections
For Each oHead In oSec.Headers
If oHead.Exists Then oHead.Range.Delete
Next oHead
For Each oFoot In oSec.Footers
If oFoot.Exists Then oFoot.Range.Delete
Next oFoot
ActiveDocument.Sections.Item(1).Headers(wdHeaderFo oterPrimary).Range.InlineShapes.AddPicture FileName:="https://intranet.ggh.uk/elements/20161003_Ensure_insurance_certificate_header.png"
ActiveDocument.Sections.Item(1).Footers(wdHeaderFo oterPrimary).Range.InlineShapes.AddPicture FileName:="https://intranet.ggh.uk/elements/20161003_Ensure_insurance_certificate_footer.png"
ActiveDocument.Save
ActiveDocument.Close
Next oSec
Next
Application.ScreenUpdating = True
End With
MsgBox "All selected files were updated, saved and closed. Please double check every document individually!", vbInformation
End Sub
Reply With Quote
  #2  
Old 10-05-2016, 05:43 AM
gmayor's Avatar
gmayor gmayor is offline Macro for inserting and formatting headers and footers Windows 10 Macro for inserting and formatting headers and footers Office 2016
Expert
 
Join Date: Aug 2014
Posts: 4,101
gmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud of
Default

When the source and target documents are differently formatted with respect to margins, working out where to position the images can be something of a trial, but given the examples the following should be close:

Code:
Option Explicit

Private Sub CommandButton3_Click()
Dim MyDialog As FileDialog, GetStr(1 To 100) As String
Dim Doc As Document
Dim stiSelectedItem As Variant
Dim i As Integer, j As Integer
    On Error Resume Next
    Set MyDialog = Application.FileDialog(msoFileDialogFilePicker)
    With MyDialog
        .Filters.Clear
        .Filters.Add "All WORD File ", "*.docx", 1
        .AllowMultiSelect = True
        i = 1
        If .Show = -1 Then
            For Each stiSelectedItem In .SelectedItems
                GetStr(i) = stiSelectedItem
                i = i + 1
            Next
            i = i - 1
        End If
        Application.ScreenUpdating = False
        For j = 1 To i Step 1
            Set Doc = Documents.Open(FileName:=GetStr(j), Visible:=True)
            ReplaceHeaderFooter Doc
            Doc.Save
            Doc.Close
        Next
        Application.ScreenUpdating = True
    End With
lbl_Exit:
    Set MyDialog = Nothing
    Set Doc = Nothing
    Exit Sub
End Sub


Sub ReplaceHeaderFooter(ByVal oDoc As Document)
Dim oSec As Section
Dim oHead As HeaderFooter
Dim oFoot As HeaderFooter
Dim oRng As Range
Dim oShape As InlineShape
    For Each oSec In oDoc.Sections
        For Each oHead In oSec.Headers
            If oHead.Exists Then
                Set oRng = oHead.Range
                With oRng
                    .ParagraphFormat.RightIndent = InchesToPoints(0.4)
                    .Text = Chr(13)
                    .Collapse 0
                    .ParagraphFormat.Alignment = wdAlignParagraphRight
                    Set oShape = .InlineShapes.AddPicture(FileName:="https://intranet.ggh.uk/elements/20161003_Ensure_insurance_certificate_header.png")
                    oShape.Width = InchesToPoints(1.42)
                    oShape.Height = InchesToPoints(1.07)
                End With
            End If
        Next oHead
        For Each oFoot In oSec.Footers
            If oFoot.Exists Then
                Set oRng = oFoot.Range
                With oRng
                    .ParagraphFormat.LeftIndent = InchesToPoints(-0.9)
                    .Text = ""
                    .ParagraphFormat.Alignment = wdAlignParagraphLeft
                    Set oShape = .InlineShapes.AddPicture(FileName:="https://intranet.ggh.uk/elements/20161003_Ensure_insurance_certificate_footer.png")
                    oShape.Width = InchesToPoints(8.27)
                    oShape.Height = InchesToPoints(1.88)
                End With
            End If
        Next oFoot
    Next oSec
lbl_Exit:
    Set oSec = Nothing
    Set oHead = Nothing
    Set oFoot = Nothing
    Set oShape = Nothing
    Set oRng = Nothing
    Exit Sub
End Sub
__________________
Graham Mayor - MS MVP (Word) (2002-2019)
Visit my web site for more programming tips and ready made processes www.gmayor.com
Reply With Quote
  #3  
Old 10-05-2016, 06:31 AM
Mike_Lennox Mike_Lennox is offline Macro for inserting and formatting headers and footers Windows 10 Macro for inserting and formatting headers and footers Office 2016
Novice
Macro for inserting and formatting headers and footers
 
Join Date: Oct 2016
Posts: 3
Mike_Lennox is on a distinguished road
Default

Hi Gmayor,

This looks great. Is there any chance that I could also change the "Header from Top" to 0.06" for all documents?
Reply With Quote
  #4  
Old 10-05-2016, 06:33 AM
Mike_Lennox Mike_Lennox is offline Macro for inserting and formatting headers and footers Windows 10 Macro for inserting and formatting headers and footers Office 2016
Novice
Macro for inserting and formatting headers and footers
 
Join Date: Oct 2016
Posts: 3
Mike_Lennox is on a distinguished road
Default

And also footer from bottom to 0". Thank you so so much
Reply With Quote
  #5  
Old 10-06-2016, 12:10 AM
gmayor's Avatar
gmayor gmayor is offline Macro for inserting and formatting headers and footers Windows 10 Macro for inserting and formatting headers and footers Office 2016
Expert
 
Join Date: Aug 2014
Posts: 4,101
gmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud of
Default

Add the two lines as shown below
Code:
Sub ReplaceHeaderFooter(ByVal oDoc As Document)
Dim oSec As Section
Dim oHead As HeaderFooter
Dim oFoot As HeaderFooter
Dim oRng As Range
Dim oShape As InlineShape
    For Each oSec In oDoc.Sections
        oSec.PageSetup.HeaderDistance = InchesToPoints(0.06)
        oSec.PageSetup.FooterDistance = InchesToPoints(0#)
        For Each oHead In oSec.Headers
'etc
__________________
Graham Mayor - MS MVP (Word) (2002-2019)
Visit my web site for more programming tips and ready made processes www.gmayor.com
Reply With Quote
Reply

Tags
letterhead

Thread Tools
Display Modes


Similar Threads
Thread Thread Starter Forum Replies Last Post
Macro for inserting and formatting headers and footers headers/footers scot Word 3 05-22-2015 09:45 AM
Macro for find/replace (including headers and footers) for multiple documents jpb103 Word VBA 2 05-16-2014 04:59 AM
Macro for inserting and formatting headers and footers Headers and Footers Kingsmoss Word 3 04-28-2014 02:43 PM
Macro for inserting and formatting headers and footers Headers and Footers teza2k06 Word 1 05-14-2013 11:07 AM
Headers and Footers OverAchiever13 Word 1 05-27-2010 01:30 PM

Other Forums: Access Forums

All times are GMT -7. The time now is 07:29 PM.


Powered by vBulletin® Version 3.8.11
Copyright ©2000 - 2024, vBulletin Solutions Inc.
Search Engine Optimisation provided by DragonByte SEO (Lite) - vBulletin Mods & Addons Copyright © 2024 DragonByte Technologies Ltd.
MSOfficeForums.com is not affiliated with Microsoft