Edit (replace text) header VBA (1 Viewer)

Gasman

Enthusiastic Amateur
Local time
Today, 10:14
Joined
Sep 21, 2011
Messages
14,038
Hi all,

Word 2007.

I found some code on the net and amended it to do as I need.

I tested it at home and it worked fine.

I emailed myself the .docm document with the code in it.

When I run it in work on my new computer, it wipes out the header completely and also creates a second page.?

Can anyone please explain what I am missing?

I thought it might be due to references as this computer is new, but it does not complain about any code at all.

TIA

Code:
Sub EditHeader()
    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
    
    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.Sections(1)
            'remove all existing headers and footers
        '    Call RemoveHeadAndFoot
        'End With
        With Doc.Sections(1)
            'insert new headers
            'strText = .Headers(wdHeaderFooterPrimary).Range.Text
            'now replace the text
            'strText = Replace(strText, "aaaa", "bbbbb")
            'strText = Replace(strText, "cccc", "ddddd")
            .Headers(wdHeaderFooterPrimary).Range.Text = Replace(.Headers(wdHeaderFooterPrimary).Range.Text, "aaaa", "bbbb)
            .Headers(wdHeaderFooterPrimary).Range.Text = Replace(.Headers(wdHeaderFooterPrimary).Range.Text, "cccc", "ddddd")
            .Headers(wdHeaderFooterPrimary).Range.Text = Replace(.Headers(wdHeaderFooterPrimary).Range.Text, "eeee", "fffff")
            .Headers(wdHeaderFooterPrimary).Range.Text = Replace(.Headers(wdHeaderFooterPrimary).Range.Text, "gggg", "hhhhh")
            .Headers(wdHeaderFooterPrimary).Range.Text = Replace(.Headers(wdHeaderFooterPrimary).Range.Text, "iiii", "jjjjj")
            .Headers(wdHeaderFooterPrimary).Range.Text = Replace(.Headers(wdHeaderFooterPrimary).Range.Text, "kkkk", "lllll")
            
            '.Range.Paragraphs.Alignment = wdAlignParagraphRight
        End With
        'With ActiveDocument.Sections(1)
            'insert new footers
            'Call editfooter
        'End With
        Doc.Save
        Doc.Close
    Next i
    
Err_Exit:
Set docToOpen = Nothing
Set Doc = Nothing

End Sub
 

kevlray

Registered User.
Local time
Today, 03:14
Joined
Apr 5, 2010
Messages
1,046
Because I wanted to see the code better. I copied the above code to Word (VBA) and noticed that you are missing a closing " on your first .Header line. The code should not execute. As far as the rest of the code. I see nothing that would create a new document. Furthermore, I tested the code and it seems to preform as expected.
 
Last edited:

Gasman

Enthusiastic Amateur
Local time
Today, 10:14
Joined
Sep 21, 2011
Messages
14,038
Thank you Kev,

That is a typo on my part as I amended the text as it had personal details in it, and missed off that last " character.

It worked at home also on 2007, which is why it puzzled me. I am taking the files home tonight and will try and amend there.

Thank you for trying it out and confirming it works for you.
 

Gasman

Enthusiastic Amateur
Local time
Today, 10:14
Joined
Sep 21, 2011
Messages
14,038
Well I am trying the actual documents at home and they fail as well.
As far as I can tell, if there is no graphic in the header, the replace works.

The address I am trying to change is in a text box in the header and when I was testing, trying this out, I did not use a text box, as I did not realise that was how the text was being stored. :(

Ah well, a lot of copy and paste to do now. :)

You live and learn.
 

kevlray

Registered User.
Local time
Today, 03:14
Joined
Apr 5, 2010
Messages
1,046
Some years back, one of my clients wanted to be able to put data into the footer when they opened the document (Probably before this forum existed). It took a lot of digging to find the right code to get it to work. I understand your pain :)
 

Gasman

Enthusiastic Amateur
Local time
Today, 10:14
Joined
Sep 21, 2011
Messages
14,038
Hi Kev,

I even found an old thread by Galaxiom with supplied code and could not get that to work.
I believe I have several sections in the header.
A Picture on the left, a text box in the middle and a text box on the right that holds the address I was trying to amend.

Plain text is fine, and that is what I tested on, not realising that there are subtle differences with text box.

I even found an old thread http://www.access-programmers.co.uk/forums/showthread.php?t=227122&highlight=replace+text and could not get that to work, even in the main document, so will revisit that when I have time. Fortunately the headers will not change again for a good while (I hope), but it would be nice to be able to do it. :)
 

Gasman

Enthusiastic Amateur
Local time
Today, 10:14
Joined
Sep 21, 2011
Messages
14,038
Well I am getting there :D

Found some code to edit text box at https://www.experts-exchange.com/questions/27274592/Word-VBA-access-Text-box-in-header.html

Code:
Sub EditHeaderTextBox()
Dim sh As Shape

For Each sh In ActiveDocument.Sections(1).Headers(wdHeaderFooterPrimary).Shapes
    If sh.Type = msoTextBox Then
        sh.TextFrame.TextRange.Text = "Some text"
    End If
Next sh
End Sub
and amended it to
Code:
Sub EditHeaderTextBox()
Dim sh As Shape

For Each sh In ActiveDocument.Sections(1).Headers(wdHeaderFooterPrimary).Shapes
    If sh.Type = msoTextBox Then
        sh.TextFrame.TextRange.Text = Replace(sh.TextFrame.TextRange.Text, "XXX Business Centre", "Line 1 replaced")
        sh.TextFrame.TextRange.Text = Replace(sh.TextFrame.TextRange.Text, "Pembrokeshire House", "Line 2 replaced")
        
    End If
Next sh
End Sub

This does the substitution correctly :D, but corrupts the alighment (right) and mucks up the other text box which is centered, so added a check for the text box name.

I had to find the name of the text box in the Locals window. I could not see any way of naming when creating a text box.

Then tweaked it with the Intellisense to get

Code:
Sub EditHeaderTextBox()
Dim sh As Shape

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, "XXX Business Centre", "Line 1 replaced")
        sh.TextFrame.TextRange.Text = Replace(sh.TextFrame.TextRange.Text, "Pembrokeshire House", "Line 2 replaced")
        sh.TextFrame.TextRange.Paragraphs.Alignment = wdAlignParagraphRight
        
    End If
Next sh
End Sub

Wish I had this the other night. :banghead:

Learnt a lot tonight. :)
 

Users who are viewing this thread

Top Bottom