![]() |
|
#1
|
|||
|
|||
|
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 |
|
#2
|
||||
|
||||
|
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 |
|
#3
|
|||
|
|||
|
Hi Gmayor,
This looks great. Is there any chance that I could also change the "Header from Top" to 0.06" for all documents? |
|
#4
|
|||
|
|||
|
And also footer from bottom to 0". Thank you so so much
|
|
#5
|
||||
|
||||
|
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 |
|
| Tags |
| letterhead |
| Thread Tools | |
| Display Modes | |
|
|
Similar Threads
|
||||
| Thread | Thread Starter | Forum | Replies | Last Post |
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 |
Headers and Footers
|
Kingsmoss | Word | 3 | 04-28-2014 02:43 PM |
Headers and Footers
|
teza2k06 | Word | 1 | 05-14-2013 11:07 AM |
| Headers and Footers | OverAchiever13 | Word | 1 | 05-27-2010 01:30 PM |