Add Shape on every Header of each Section

Souriane · #1 12-05-2022, 12:12 PM

Hi!

The following code adds a TextBox on each Header of each Section. It works fine as long as there is no continuous section brakes. When there are continuous section brakes, the code inserts as many TextBoxes as there is continuous section brakes + one more TextBox, and does that on the following section!

So, on my first page, I have 2 continuous sections brakes + 1 section next page = I get on the first page ONE text box, and on the second page FOUR text boxes!

What should I change?

Code:

Sub MyMacro()
    
    Dim oSection As Section
    Dim oHeader As HeaderFooter
    Dim Boite As Shape

    For Each oSection In ActiveDocument.Sections
        For Each oHeader In oSection.Headers
            If oHeader.Exists Then
                
                Set Boite = oHeader.Shapes.AddTextBox( _
                Orientation:=msoTextOrientationHorizontal, _
                Left:=50, Top:=50, Width:=460, Height:=120)
                
                With Boite
                    .TextFrame.TextRange.Text = "PROJET"
                    .TextFrame.TextRange.Font.Name = "Arial Black"
                    .TextFrame.TextRange.Font.Size = 100
                    .TextFrame.TextRange.Font.Color = -603923969
                    .TextFrame.MarginLeft = 0#
                    .TextFrame.MarginRight = 0.5
                    .TextFrame.MarginTop = 0#
                    .TextFrame.MarginBottom = 0#
                    .Line.DashStyle = msoLineSolid
                    .Line.Style = msoLineSingle
                    .Line.Transparency = 0#
                    .Line.Visible = msoFalse
                    .Left = wdShapeRight
                    .WrapFormat.Type = wdWrapBehind
                    .Rotation = 315
                    .LockAspectRatio = True
                    .RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
                    .RelativeVerticalPosition = wdRelativeHorizontalPositionPage
                    .Top = 400
                    .Left = 125
                End With
            End If
        Next oHeader
    Next oSection
End Sub

Thank you!

Souriane

macropod · #2 12-05-2022, 03:46 PM

For example:

Code:

Sub Demo()
Application.ScreenUpdating = False
Dim s As Long, HdFt As HeaderFooter, Shp As Shape, Rng As Range
With ActiveDocument
  For s = 1 To .Sections.Count
    Select Case s
      Case 1
        For Each HdFt In .Sections(s).Headers
          With HdFt
            If .Exists Then
              If Shp Is Nothing Then
                Set Rng = .Range.Characters.First: Rng.Collapse wdCollapseStart
                Set Shp = .Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, _
                  Left:=50, Top:=50, Width:=460, Height:=120, Anchor:=Rng)
                With Shp
                  With .Line
                    .DashStyle = msoLineSolid
                    .Style = msoLineSingle
                    .Transparency = 0#
                    .Visible = msoFalse
                  End With
                  With .TextFrame
                    With .TextRange
                      .Text = "PROJET"
                      .Font.Name = "Arial Black"
                      .Font.Size = 100
                      .Font.Color = -603923969
                    End With
                    .MarginLeft = 0#
                    .MarginRight = 0.5
                    .MarginTop = 0#
                    .MarginBottom = 0#
                  End With
                  .Left = wdShapeRight
                  .WrapFormat.Type = wdWrapBehind
                  .Rotation = 315
                  .LockAspectRatio = True
                  .RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
                  .RelativeVerticalPosition = wdRelativeHorizontalPositionPage
                  .Top = 400
                  .Left = 125
                  .LockAnchor = True
                End With
              Else
                Set Rng = .Range.Characters.First: Rng.Collapse wdCollapseStart
                Rng.FormattedText = Shp.Anchor.FormattedText
              End If
            End If
          End With
        Next
      Case Else
        For Each HdFt In .Sections(s).Headers
          With HdFt
            If .Exists Then
              If .LinkToPrevious = False Then
                Set Rng = .Range.Characters.First: Rng.Collapse wdCollapseStart
                Rng.FormattedText = Shp.Anchor.FormattedText
              End If
            End If
          End With
        Next
    End Select
  Next
End With
Set Rng = Nothing: Set Shp = Nothing
Application.ScreenUpdating = True
End Sub

Guessed · #3 12-05-2022, 03:47 PM

Using shapes rather than inline shapes is a problem in headers. See this thread for discussions on where the problems are that you will encounter.
https://www.msofficeforums.com/word-...en-though.html

Is there a reason your layout can't use an inline table instead of a text box? I would recommend you explore any options to avoid floating shapes first.

Souriane · #4 12-06-2022, 07:01 AM

@Guessed: had never understood the difference between Shapes and InlineShapes. Went to read on the subject and it make alot of sense with my problem (and a few others I had in the past)! Thank you so much!

@Macropod: the code works great except the shapes do not rotate. Can't figure out why. I tried changing a few things in the code and nope. But if I do it manually on the shape, after the code, it works. So the shapes are note "broken"

If you don't know, I will work to change the code from Shapes to InlineShape as Guessed suggested.

And thanks again to both of you!! You really helped me today and many many other times!

Souriane

macropod · #5 12-06-2022, 04:43 PM

Quote:

Originally Posted by Souriane

@Macropod: the code works great except the shapes do not rotate. Can't figure out why. I tried changing a few things in the code and nope.

The code works fine for me. In any event, the rotation code is exactly what you had. Have you tried re-starting Word/Windows?

Quote:

Originally Posted by Souriane

If you don't know, I will work to change the code from Shapes to InlineShape as Guessed suggested.

InlineShapes can't be rotated.

Souriane · #6 12-08-2022, 06:35 AM

>> Have you tried re-starting Word/Windows?

That was the solution! Thank you very much for your time! Have a nice day!

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
When I copy a shape into another document it becomes a picture. I want a shape.	FJM	Word	4	02-24-2022 09:59 AM
Visio 2016 New homemade Shape Data export with Network Shape Data	Karlderxte	Visio	1	08-17-2021 04:04 PM
Fit text to shape / Place table in shape	Floppy	PowerPoint	0	04-01-2021 11:01 AM
Word Mac 2010 VBA Draw shape shortcut, irregular shape, draw without graphics tablet like in paint	AnonA2	Word VBA	0	11-24-2020 04:21 PM
How to change size / shape of a shape in a stencil	tomgoodell	Visio	1	06-30-2016 04:40 AM