Split a text box of bullets into one text box per bullet

[RayKay]

Hi John, I've updated the code and spent hours trying to fit it, but really need your expertise help please.

When a text box is selected, it converts the bullets to separate text boxes (we do this often, but our old tool has no VBA to access).

Below code currently puts the separate text boxes on the right, rather than deleting the original text box and putting the new text boxes in its place. :(

Plus my error message... if someone clicks the button with a text box it works fine, but the error message appears when it shouldn't. It should only appear if not text box was selected, which works fine.

Thanks in advance :thumb:



Sub SplitTextBoxes()


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, 400, oshp.Top + x, 400, 15)
.TextFrame2.AutoSize = msoAutoSizeNone
.TextFrame2.VerticalAnchor = msoAnchorTop
.TextFrame2.MarginBottom = 0
.TextFrame2.MarginTop = 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(255, 255, 255)
.ParagraphFormat.LeftIndent = 14.3
.ParagraphFormat.FirstLineIndent = -14.3
End With
End With
x = x + 20
Next L
End With
End If
End If
err:
MsgBox "Please select a text box"
End Sub

[John Wilson]

I'm back working on paying projects from today so you will see less of me!

Try starting with:


Sub SplitTextBoxes()
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 = otr.Text
.Font.Size = 12
.Font.Bold = False
.ParagraphFormat.Alignment = msoAlignLeft
'not sure why you are adding white bullets but these lines are probably not needed
'.ParagraphFormat.Bullet.Visible = True
'.ParagraphFormat.Bullet.Character = 167
'.ParagraphFormat.Bullet.Font.Name = "WingDings"
'.ParagraphFormat.Bullet.Font.Fill.ForeColor.RGB = RGB(255, 255, 255)
'.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

[RayKay]

Thank you John. I just added:

.TextFrame2.MarginLeft = 0
.TextFrame2.MarginRight = 0

Brilliant. When I first volunteered to improve an old ribbon, it had only 5 tools, now it looks much better, thank you. I'm learning a lot, you've been wonderful. I'm really grateful for your help. Of course, work takes priority :) and thank you!! Have a great day! :thumb