Amend text shape in header with VBA

macropod · #8 09-21-2016, 06:47 AM

Try the following:

Code:

Sub EditHeaderTextBox()
Dim Shp As Shape, Doc As Document, strText As String
Dim i As Long, docToOpen As FileDialog, sHght As Single
 
    On Error GoTo Err_Exit
    strText = InputBox("New Text", "Header Textbox Update", "New Text")
 
    ' Switch off the updates of screen
    Application.ScreenUpdating = False
 
    Set docToOpen = Application.FileDialog(msoFileDialogFilePicker)
    docToOpen.Show
    For i = 1 To docToOpen.SelectedItems.Count
        'Open each document
        Set Doc = Documents.Open(FileName:=docToOpen.SelectedItems(i))
        With Doc
            With .Sections(1)
                For Each Shp In .Headers(wdHeaderFooterPrimary).Shapes
                    With Shp
                        If .Type = msoTextBox And .Name = "Text Box 1" Then
                            With .TextFrame
                                .AutoSize = True
                                .MarginLeft = 0
                                With .TextRange
                                    With .Font
                                        .Name = "Arial"
                                        .Size = 10
                                    End With
                                    .Text = strText
                                End With
                            End With
                            .RelativeVerticalPosition = wdRelativeVerticalPositionPage
                            sHght = .Top + .Height
                        Else
                            sHght = 0
                        End If
                    End With
                  If sHght <> 0 Then .PageSetup.TopMargin = sHght
                Next
            End With
            .Close SaveChanges:=wdSaveChanges
        End With
    Next
 
    Set docToOpen = Nothing: Set Doc = Nothing
    ' Switch Screen updates back on
    Application.ScreenUpdating = True
    Exit Sub
Err_Exit:
    MsgBox Err.Description & Err.Number
End Sub

Another problem you'll most likely have is that you have not only a textbox but also a horizontal line and the latter doesn't move when the header is resized. You could obviate that problem by:
1. deleting the blue line;
2. changing the textbox wrapping to 'inline'; and
3. formatting the paragraph containing the textbox as right-aligned with a blue bottom border and left/right margins of -2.5 cm.
You could then use:

Code:

Sub EditHeaderTextBox()
Dim Shp As Shape, Doc As Document, strText As String
Dim i As Long, docToOpen As FileDialog
 
    On Error GoTo Err_Exit
    strText = InputBox("New Text", "Header Textbox Update", "New Text")
 
    ' Switch off the updates of screen
    Application.ScreenUpdating = False
 
    Set docToOpen = Application.FileDialog(msoFileDialogFilePicker)
    docToOpen.Show
    For i = 1 To docToOpen.SelectedItems.Count
        'Open each document
        Set Doc = Documents.Open(FileName:=docToOpen.SelectedItems(i))
        With Doc
            With .Sections(1)
                For Each Shp In .Headers(wdHeaderFooterPrimary).Shapes
                    With Shp
                        If .Name = "Text Box 1" Then
                            With .TextFrame
                                .AutoSize = True
                                .MarginLeft = 0
                                With .TextRange
                                    With .Font
                                        .Name = "Arial"
                                        .Size = 10
                                    End With
                                    .Text = strText
                                End With
                            End With
                        End If
                    End With
                Next
            End With
            .Close SaveChanges:=wdSaveChanges
        End With
    Next
 
    Set docToOpen = Nothing: Set Doc = Nothing
    ' Switch Screen updates back on
    Application.ScreenUpdating = True
    Exit Sub
Err_Exit:
    MsgBox Err.Description & Err.Number
End Sub

Even so, unless you plan to have the header content on every page, I'd be inclined to use a 'different first page setup' and put the header content in the first page header, with the attendant code change of:
wdHeaderFooterPrimary
to:
wdHeaderFooterFirstPage
That way, your other pages will also not require as much space for the header if it expands beyond whatever your default page margins are on the first page.

Thread Tools
Show Printable Version Email this Page
Display Modes
Switch to Linear Mode Switch to Hybrid Mode Threaded Mode

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
selecting shape in header only	mhagi	Word VBA	5	10-09-2015 01:10 AM
Get the TEXT of Clicked Shape	exceere	Excel Programming	9	07-09-2014 06:51 AM
how to paste text as shape	bsapaka	Excel	1	05-01-2014 06:53 AM
Excel vba adding field in word table/shape in a header	Hdr	Excel	1	02-04-2013 04:40 PM
Amend footer in multiple word docs?	compact	Word	2	02-24-2009 09:40 AM