Splitting a Text Box so each Bullet has its own text box

[RayKay]

Hi John, my last problem I can't solve... I need to recreate this tool, but I only have the .ppam file :(

I need to split one text box of bullets so each bullet is in it's own text box. I've attached a PowerPoint slide visually explaining a bit better.

It's used because often we split a text box of bullets into one bullet per box, and then we can paste data from Think-Cell using the PPTX clipboard (a feature Think-Cell has, an add-in for PowerPoint).

My code so far, but it bolds/centers and changes bullets :(

Any help is appreciated, thank you.
PS: Made a small donation, enjoy some wine :) I'm so grateful for your help.

Code:

Sub SplitBullets8()


Dim oShp As Shape
Dim oTB As Shape
Dim oSld As Slide
Dim L As Long
Dim sngT As Single
Dim sngW As Single
Dim sngL As Single
Dim otxR1 As TextRange
Dim FM As Single
Dim LM As Single


Dim fontsz As Long
'On Error GoTo err
Set oShp = ActiveWindow.Selection.ShapeRange(1)
sngL = oShp.Left
sngW = oShp.Width
Set oSld = oShp.Parent
fontsz = oShp.TextFrame.TextRange.Paragraphs(1).Font.Size
Set otxR1 = oShp.TextFrame.TextRange.Paragraphs(1)
LM = oShp.TextFrame.Ruler.Levels(1).LeftMargin
FM = oShp.TextFrame.Ruler.Levels(1).FirstMargin
For L = 1 To oShp.TextFrame.TextRange.Paragraphs.Count


If L = 1 Then
sngT = oShp.Top
Else
sngT = otxR1.BoundTop + otxR1.BoundHeight
End If


Set oTB = oSld.Shapes.AddTextbox(msoTextOrientationHorizontal, sngL, sngT, sngW, 10)
oTB.TextFrame.TextRange.Text = oShp.TextFrame2.TextRange.Paragraphs(L).Text


Set otxR1 = oTB.TextFrame.TextRange
While Right(otxR1.Text, 1) = Chr(13)
otxR1.Text = Left(otxR1.Text, Len(otxR1.Text) - 1)
Wend


otxR1.ParagraphFormat.Bullet.Visible = _
oShp.TextFrame2.TextRange.Paragraphs(L).ParagraphFormat.Bullet.Visible
otxR1.ParagraphFormat.Bullet.Type = _
oShp.TextFrame.TextRange.Paragraphs(L).ParagraphFormat.Bullet.Type
oTB.TextFrame.TextRange.Font.Size = fontsz
oTB.TextFrame.Ruler.Levels(1).FirstMargin = FM
oTB.TextFrame.Ruler.Levels(1).LeftMargin = LM
Next L
oShp.TextFrame.DeleteText
oShp.Delete
Exit Sub
err:
MsgBox "Error, " & err.Description
End Sub

[John Wilson]

Sub splitParas()

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
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.LeftIndent = 14.3
.ParagraphFormat.FirstLineIndent = -14.3
End With
End With
x = x + 20
Next L
End With
End If
End If
End Sub

[RayKay]

THANK YOU !!!

Can I specify a RGB color for the bullet points?

Thank you :)

[John Wilson]

Just add this line in the ParagraphFormat Lines

.ParagraphFormat.Bullet.Font.Fill.ForeColor.RGB = RGB(255, 0, 0)

[RayKay]

Thanks, I tried so many different things, i.e. .ParagraphFormat.Bullet.Font.Color.RGB = RGB(255, 0, 0). Your code of course worked, thank you!