none
Add Shape beside each Paragraph RRS feed

  • Question

  • Hi All,

    I've been trying to get this macro right. My purpose is to add a customized textbox beside each paragraph with a macro. 

    This is what I have so far:

    Sub TextBox()
    
    Dim Par As Paragraph
    Dim Rng As Range
    Dim Shp As Shape
    
    Set Rng = ActiveDocument.Range
    For Each Par In Rng.Paragraphs
    
       Set Shp = ActiveDocument.Shapes.AddShape(msoShapeRectangle, 0, 0, 30, 12)
     
        With Shp
        
     For Each Shp In ActiveDocument.Shapes
     .TextFrame.TextRange.Font.Size = 7
            .TextFrame.TextRange.Font.ColorIndex = wdWhite
            .Line.Visible = msoTrue
            .Line.ForeColor.RGB = 0
            .Fill.Visible = msoTrue
            .Fill.ForeColor.RGB = 200
            .Width = 25#
            .Height = 10#
            .Left = -30
            .Top = 10
            .RelativeHorizontalPosition = wdRelativeHorizontalPositionLeftMarginArea
            .RelativeVerticalPosition = wdRelativeVerticalPositionParagraph
            .Top = wdShapeTop
            .Left = wdShapeRight
            
        Next
        Set Shp = Nothing
             
    End With
    Next
    End Sub
    

    Problem with my current code is that shapes getting added but instead of one shape for one paragraph its getting added in to the first paragraph only.Kindly Help me with this. Thanks in advance.


    Regards, Supun Samarakoon

    Thursday, June 14, 2018 11:03 AM

Answers

  • Try:

    Sub TextBox()
    Application.ScreenUpdating = False
    Dim Shp As Shape, ShpRng As Range, ParRng As Range, i As Long
    With ActiveDocument
      Set Shp = .Shapes.AddShape(msoShapeRectangle, 0, 0, 30, 12)
      With Shp
        .TextFrame.TextRange.Font.Size = 7
        .TextFrame.TextRange.Font.ColorIndex = wdWhite
        .Line.Visible = msoTrue
        .Line.ForeColor.RGB = 0
        .Fill.Visible = msoTrue
        .Fill.ForeColor.RGB = 200
        .Width = 25#
        .Height = 10#
        .Left = -30
        .Top = 10
        .RelativeHorizontalPosition = wdRelativeHorizontalPositionLeftMarginArea
        .RelativeVerticalPosition = wdRelativeVerticalPositionParagraph
        .Top = wdShapeTop
        .Left = wdShapeRight
        Set ShpRng = .Anchor
      End With
      For i = 2 To .Paragraphs.Count
        Set ParRng = .Paragraphs(i).Range
        With ParRng
          .Collapse wdCollapseStart
          .FormattedText = ShpRng.FormattedText
        End With
      Next
    End With
    Application.ScreenUpdating = True
    End Sub


    Cheers
    Paul Edstein
    [MS MVP - Word]

    • Marked as answer by Supunsam Friday, June 15, 2018 3:29 AM
    Friday, June 15, 2018 12:09 AM

All replies

  • Try:

    Sub TextBox()
    Application.ScreenUpdating = False
    Dim Shp As Shape, ShpRng As Range, ParRng As Range, i As Long
    With ActiveDocument
      Set Shp = .Shapes.AddShape(msoShapeRectangle, 0, 0, 30, 12)
      With Shp
        .TextFrame.TextRange.Font.Size = 7
        .TextFrame.TextRange.Font.ColorIndex = wdWhite
        .Line.Visible = msoTrue
        .Line.ForeColor.RGB = 0
        .Fill.Visible = msoTrue
        .Fill.ForeColor.RGB = 200
        .Width = 25#
        .Height = 10#
        .Left = -30
        .Top = 10
        .RelativeHorizontalPosition = wdRelativeHorizontalPositionLeftMarginArea
        .RelativeVerticalPosition = wdRelativeVerticalPositionParagraph
        .Top = wdShapeTop
        .Left = wdShapeRight
        Set ShpRng = .Anchor
      End With
      For i = 2 To .Paragraphs.Count
        Set ParRng = .Paragraphs(i).Range
        With ParRng
          .Collapse wdCollapseStart
          .FormattedText = ShpRng.FormattedText
        End With
      Next
    End With
    Application.ScreenUpdating = True
    End Sub


    Cheers
    Paul Edstein
    [MS MVP - Word]

    • Marked as answer by Supunsam Friday, June 15, 2018 3:29 AM
    Friday, June 15, 2018 12:09 AM
  • Hi Paul,

    As always you are the best. Thank you very much for this. It works great and at a great speed. More than I was hoping for.


    Regards, Supun Samarakoon

    Friday, June 15, 2018 3:29 AM