Consulting

Results 1 to 2 of 2

Thread: Split Text Box by Bullets with no extra return

  1. #1
    VBAX Contributor
    Joined
    Dec 2018
    Posts
    105
    Location

    Split Text Box by Bullets with no extra return

    Hi John

    I used this code you kindly created; I can't find how to remove the extra 'return' it puts in each next bullet's text box?
    I've experimented, but alas, no luck. Thank you and have a super weekend!

    Code:

    Sub SplitTextBoxes()
    
    
    Dim oShp As Shape
    Dim osld As Slide
    Dim L As Long
    Dim otr As TextRange2
    Dim X As Integer
        On Error GoTo err
    Set oShp = ActiveWindow.Selection.ShapeRange(1)
    Set osld = oShp.Parent
    On Error GoTo err
    If oShp.HasTextFrame Then
    If oShp.TextFrame2.HasText Then
    With oShp.TextFrame2.TextRange
    For L = 1 To .Paragraphs.Count
    Set otr = .Paragraphs(L)
    With osld.Shapes.AddTextbox(msoTextOrientationHorizontal, oShp.Left, oShp.Top + X, 400, 15)
    .TextFrame2.AutoSize = msoAutoSizeShapeToFitText
    .TextFrame2.VerticalAnchor = msoAnchorTop
    .TextFrame2.MarginBottom = 0
    .TextFrame2.MarginTop = 0
    .TextFrame2.MarginLeft = 0
    .TextFrame2.MarginRight = 0
    With .TextFrame2.TextRange
    .Text = otr.Text
    .Font.Size = 12
    .Font.Bold = False
    .ParagraphFormat.Alignment = msoAlignLeft
    .ParagraphFormat.Bullet.visible = True
    .ParagraphFormat.Bullet.Character = 167
    .ParagraphFormat.Bullet.Font.Name = "WingDings"
    .ParagraphFormat.Bullet.Font.Fill.ForeColor.RGB = RGB(219, 0, 17)
    .ParagraphFormat.LeftIndent = 14.3
    .ParagraphFormat.FirstLineIndent = -14.3
    End With
    X = X + .Height
    End With
    Next L
    End With
    End If
    End If
    oShp.Delete
    Exit Sub
    err:
    MsgBox "Please select a text box"
    End Sub

  2. #2
    Try this:

    Sub Split_Text_Boxes()
    Dim oshp As Shape
    Dim osld As Slide
    Dim L As Long
    Dim otr As TextRange2
    Dim x As Integer
    Set oshp = ActiveWindow.Selection.ShapeRange(1)
    Set osld = oshp.Parent
    On Error GoTo err
    If oshp.HasTextFrame Then
    If oshp.TextFrame2.HasText Then
    With oshp.TextFrame2.TextRange
    For L = 1 To .Paragraphs.Count
    Set otr = .Paragraphs(L)
    With osld.Shapes.AddTextbox(msoTextOrientationHorizontal, oshp.Left, oshp.Top + x, 400, 15)
    .TextFrame2.AutoSize = msoAutoSizeShapeToFitText
    .TextFrame2.VerticalAnchor = msoAnchorTop
    .TextFrame2.MarginBottom = 0
    .TextFrame2.MarginTop = 0
    With .TextFrame2.TextRange
    .Text = Replace(otr.Text, vbCr, "")
    .Font.Size = 12
    .Font.Bold = False
    .ParagraphFormat.Alignment = msoAlignLeft
    End With
    x = x + .Height
    End With
    Next L
    End With
    End If
    End If
    oshp.Delete
    Exit Sub
    err:
    MsgBox "Please select a text box"
    End Sub
    Last edited by Aussiebear; 12-21-2021 at 03:57 AM. Reason: Added code tags to supplied code

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •