#1
|
|||
|
|||
Amend text shape in header with VBA
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 |
#2
|
||||
|
||||
Without seeing you code, it's impossible to provide specific advice on what changes might be needed.
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#3
|
|||
|
|||
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 Code:
'What.TextFrame.TextRange.InsertParagraph What.TextFrame.TextRange.InsertAfter "The quick brown monkey jumped over the lazy elephant's back" Would still need to adjust the header depth for any increase in depth of the textbox. TIA |
#4
|
||||
|
||||
Quote:
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 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
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#5
|
|||
|
|||
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 How would I do that please. I've tried looking in the properties, but have yet to find the correct value. TIA |
#6
|
||||
|
||||
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
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#7
|
|||
|
|||
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 |
#8
|
||||
|
||||
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 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 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.
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#9
|
|||
|
|||
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. |
#10
|
||||
|
||||
Quote:
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.
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
|
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 |