Amend text shape in header with VBA

Welshgasman · #1 09-16-2016, 01:27 PM

Hi all,

I managed to create a sub that allows me to change text in the header of word documents. We moved address in work and there were so many to change, I decided to write the routine.

Now I need to use it on another set of letters in the same way.

Unfortunately all it does is swap text in the textbox shape.
Now I need to add an extra line. I believe I could do that with vbCRLF and with some text. However my manager wants to also enlarge the font from 8 to 10, and this then exceeds the size of the text shape.

So I believe I need to somehow change the size of the text shape, but cannot find the method/properties to do it.? I've looked at MarginTop, Autosize etc.
The text shape is also going to have to move to the left to accommodate the larger size and the header depth is also going to have to grow to accommodate the text box.

Would anyone be able to tell me the properties I could use to do the above please.?

TIA

macropod · #2 09-16-2016, 06:21 PM

Without seeing you code, it's impossible to provide specific advice on what changes might be needed.

Welshgasman · #3 09-19-2016, 01:02 AM

Good morning,

Here is my existing code

Code:

Sub EditHeaderTextBox()
Dim sh As Shape
    Dim Doc As Document
    Dim i As Integer
    Dim docToOpen As FileDialog
    Dim strText As String
    Dim blnSave As Boolean
    
    blnSave = True
    
    On Error GoTo Err_Exit
    
    ' 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))
        ' *** Always use the AlignRight code loine as editing bugegrs up the alignment ***
        For Each sh In ActiveDocument.Sections(1).Headers(wdHeaderFooterPrimary).Shapes
            If sh.Type = msoTextBox And sh.Name = "Text Box 1" Then
                sh.TextFrame.TextRange.Text = Replace(sh.TextFrame.TextRange.Text, "aaa", "bbb")
                sh.TextFrame.TextRange.Text = Replace(sh.TextFrame.TextRange.Text, "ccc", "ddd")
                sh.TextFrame.TextRange.Text = Replace(sh.TextFrame.TextRange.Text, "eee", "fff")
                'sh.TextFrame.TextRange.Text = Replace(sh.TextFrame.TextRange.Text, "ggg", "hhh")
                'sh.TextFrame.TextRange.Text = Replace(sh.TextFrame.TextRange.Text, "iii", "jjj")
                sh.TextFrame.TextRange.Text = Replace(sh.TextFrame.TextRange.Text, "kkk", "lll")
                'sh.TextFrame.TextRange.Text = Replace(sh.TextFrame.TextRange.Text, "mmm", "nnn")
                'sh.TextFrame.TextRange.Paragraphs.Alignment = wdAlignParagraphRight
                sh.TextFrame.MarginLeft = sh.TextFrame.MarginLeft - 5
                sh.TextFrame.MarginTop = sh.TextFrame.MarginTop - 5
                sh.TextFrame.TextRange.Font.Size = 10
                sh.TextFrame.AutoSize = True
            End If
        Next sh
        Doc.Save
        Doc.Close
    Next i
    
Exit_Sub:
        ' Switch SCreen updates back on
        Application.ScreenUpdating = True
        Set docToOpen = Nothing
        Set Doc = Nothing
        Exit Sub
Err_Exit:
    MsgBox Err.Description & Err.Number
    
End Sub

I have since discovered an example on how to insert text

Code:

'What.TextFrame.TextRange.InsertParagraph
What.TextFrame.TextRange.InsertAfter "The quick brown monkey jumped over the lazy elephant's back"

an am thinking slightly differently now, in that I could delete all the existing text in the text box and add afresh?
Would still need to adjust the header depth for any increase in depth of the textbox.

TIA

macropod · #4 09-19-2016, 05:34 AM

Quote:

Originally Posted by Welshgasman

am thinking slightly differently now, in that I could delete all the existing text in the text box and add afresh?
Would still need to adjust the header depth for any increase in depth of the textbox.

You could do that with code like:

Code:

Sub EditHeaderTextBox()
Dim sh 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))
        For Each sh In Doc.Sections(1).Headers(wdHeaderFooterPrimary).Shapes
            If sh.Type = msoTextBox And sh.Name = "Text Box 1" Then
                sh.TextFrame.TextRange.Text = strText
                sh.TextFrame.AutoSize = True
            End If
        Next sh
        Doc.Save
        Doc.Close
    Next i
    
    ' Switch SCreen updates back on
    Application.ScreenUpdating = True
    Set docToOpen = Nothing
    Set Doc = Nothing
    Exit Sub
Err_Exit:
    MsgBox Err.Description & Err.Number
End Sub

though you'll have trouble inputting paragraphs breaks, etc. into an InputBox. For anything more complex than a simple text string, you'd probably do better to use and select a formatted string in the document you're running the code from, with code like:

Code:

Sub EditHeaderTextBox()
Dim sh As Shape, Doc As Document, Rng As Range
Dim i As Long, docToOpen As FileDialog
    
    On Error GoTo Err_Exit
    
    ' Switch off the updates of screen
    Application.ScreenUpdating = False
    
    Set docToOpen = Application.FileDialog(msoFileDialogFilePicker)
    docToOpen.Show
    Set Rng = Selection.Range
    For i = 1 To docToOpen.SelectedItems.Count
        'Open each document
        Set Doc = Documents.Open(FileName:=docToOpen.SelectedItems(i))
        For Each sh In Doc.Sections(1).Headers(wdHeaderFooterPrimary).Shapes
            If sh.Type = msoTextBox And sh.Name = "Text Box 1" Then
                sh.TextFrame.TextRange.FormattedText = Rng.FormattedText
                sh.TextFrame.AutoSize = True
            End If
        Next sh
        Doc.Save
        Doc.Close
    Next i
    
    ' Switch SCreen updates back on
    Application.ScreenUpdating = True
    Set docToOpen = Nothing
    Set Rng = Nothing
    Set Doc = Nothing
    Exit Sub
Err_Exit:
    MsgBox Err.Description & Err.Number
End Sub

Welshgasman · #5 09-21-2016, 01:28 AM

Paul,

The following code works great

Code:

For Each sh In ActiveDocument.Sections(1).Headers(wdHeaderFooterPrimary).Shapes
            If sh.Type = msoTextBox And sh.Name = "Text Box 1" Then
                'sh.TextFrame.TextRange.Text = Replace(sh.TextFrame.TextRange.Text, "The Business Centre", "JAG Business Centre")
                'sh.TextFrame.TextRange.Paragraphs.Alignment = wdAlignParagraphRight
                sh.TextFrame.MarginLeft = 0 'This puts the text right on the margin
                sh.TextFrame.TextRange.Font.Name = "Arial"
                sh.TextFrame.TextRange.Font.Size = 10
                sh.TextFrame.AutoSize = True
                sh.TextFrame.TextRange.Text = strText
            End If
            
        Next sh

but as I suspected I need to autosize the header height for the new font size

How would I do that please. I've tried looking in the properties, but have yet to find the correct value.

TIA

macropod · #6 09-21-2016, 02:04 AM

Try something based on:

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
                        End If
                        .RelativeVerticalPosition = wdRelativeVerticalPositionPage
                        sHght = .Top + .Height
                    End With
                Next
                .PageSetup.TopMargin = sHght
            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

Welshgasman · #7 09-21-2016, 03:05 AM

Thank you Paul,

That totally messes up the document making 38 pages where there was only one.
each line of text in the document is on a separate page.

I cannot upload one of the documents, even with the body text removed as it exceed size limits. Even a zip is 566KB.

I've removed the header graphic, and just hope that does not affect the real document.

As soon as I do that even the existing textbox exceeds the header height.

TIA

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.

Welshgasman · #9 09-22-2016, 01:10 AM

Thank you Paul.
We do have a blue line below the logo and text box, but that has moved down as well, so all is good. I'll try your modification of the sHght line when I have a spare moment.

I was thinking about it last night and *thought* I might need to check if it is > than current .PageSetup.TopMargin and then only change it, else it could be reduced depending on what is in the page header.

Only a few letters have more than page and true the header is on those pages as well.
I'll ask my manager what she prefers.

Thank you for the tip.

macropod · #10 09-22-2016, 01:16 AM

Quote:

Originally Posted by Welshgasman

We do have a blue line below the logo and text box, but that has moved down as well, so all is good.

In my testing the blue line didn't move.

Quote:

Originally Posted by Welshgasman

I was thinking about it last night and *thought* I might need to check if it is > than current .PageSetup.TopMargin and then only change it, else it could be reduced depending on what is in the page header.

With the alternative approach I suggested, such testing isn't necessary. Indeed, if you look at the code I posted for that, you'll see there's not even a reference to sHght.

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