Macros defining levels for selected text paragraphs

[RandomGerman]

Hi there,

I'm quite close to hit what I want my macros to do: They already work, but two details are not the way I want them to be, so any help is appreciated.

I defined three levels of text:
First is bold, without bullet, and on the far left of the text box
Second is plain, with a bullet, and a bit indented
Third is plain, with a different bullet, and a bit more indented

Each of my three similar macros takes care for one of these levels. When you select a whole shape, the macro handles all text the same way, when you select only parts of the text, it works only for these selected parts.

The two details are:
1. On the first click the macros for level 2 and 3 don't hit exactly the defined LeftMargin. But they do, as soon as you use one of the macros again for another paragraph. It is difficult to explain, best is, you have a look on my attachment and try what I suggested there in a box on the right.
2. Changes between bold and plain are only realized for the selection, not for the whole paragraph. This is quite logical as I didn't tell the macro to act on the whole paragraph, because I just don't know how.

Here comes the code:

Sub SetTextLevel1()
 Dim trg As TextRange
 
On Error GoTo err
 
 Set trg = ActiveWindow.Selection.TextRange
 With trg
 .IndentLevel = 1
 .ParagraphFormat.Alignment = ppAlignLeft
 With .Parent.Ruler
 .Levels(1).FirstMargin = 0
 .Levels(1).LeftMargin = 0
 .Levels(2).FirstMargin = 9.9212536
 .Levels(2).LeftMargin = 22.960615
 .Levels(3).FirstMargin = 32.031476
 .Levels(3).LeftMargin = 45.354302
 End With
 .ParagraphFormat.Bullet.Visible = msoFalse
 With .Font
 .Name = "Arial"
 .Bold = msoTrue
 .Color.RGB = RGB(0, 0, 0)
 End With
 End With
Exit Sub
 
err:
    MsgBox "Please select text or a shape"
    
 End Sub
 Sub SetTextLevel2()
 
 Dim trg As TextRange
 
On Error GoTo err
 Set trg = ActiveWindow.Selection.TextRange
 With trg
 .ParagraphFormat.Alignment = ppAlignLeft
 .IndentLevel = 2
 With .Parent.Ruler
 .Levels(1).FirstMargin = 0
 .Levels(1).LeftMargin = 0
 .Levels(2).FirstMargin = 9.9212536
 .Levels(2).LeftMargin = 22.960615
 .Levels(3).FirstMargin = 32.031476
 .Levels(3).LeftMargin = 45.354302
 End With
 With .ParagraphFormat.Bullet
 .Visible = msoTrue
 .UseTextColor = msoFalse
 .UseTextFont = msoFalse
 .RelativeSize = 1
 .Character = 8226
 With .Font
 .Color.RGB = RGB(9, 91, 164)
 End With
 End With
 With .Font
 .Name = "Arial"
 .Bold = msoFalse
 End With
 End With
 Exit Sub
 
err:
    MsgBox "Please select text or a shape"
 End Sub
 Sub SetTextLevel3()
 Dim trg As TextRange
 
On Error GoTo err
 Set trg = ActiveWindow.Selection.TextRange
 With trg
 .ParagraphFormat.Alignment = ppAlignLeft
 .IndentLevel = 3
 With .Parent.Ruler
 .Levels(1).FirstMargin = 0
 .Levels(1).LeftMargin = 0
 .Levels(2).FirstMargin = 9.9212536
 .Levels(2).LeftMargin = 22.960615
 .Levels(3).FirstMargin = 32.031476
 .Levels(3).LeftMargin = 45.354302
 End With
 With .ParagraphFormat.Bullet
 .Visible = msoTrue
 .UseTextColor = msoFalse
 .UseTextFont = msoFalse
 .RelativeSize = 1
 .Character = 8211
 With .Font
 .Color.RGB = RGB(9, 91, 164)
 End With
 End With
 With .Font
 .Name = "Arial"
 .Bold = msoFalse
 End With
 End With
  Exit Sub
 
err:
    MsgBox "Please select text or a shape"
 End Sub

And here is a document including the macro and a TextBox with suggestions what to try

SetTextLevel.pptm

Thanks for an help!

[RandomGerman]

Ok, for the first one I found a solution. Bungled in a way, but, however, it works. I just repeat the following part before the last "End With".

        With .Parent.Ruler 
            .Levels(1).FirstMargin = 0 
            .Levels(1).LeftMargin = 0 
            .Levels(2).FirstMargin = 9.9212536 
            .Levels(2).LeftMargin = 22.960615 
            .Levels(3).FirstMargin = 32.031476 
            .Levels(3).LeftMargin = 45.354302 
        End With

Of course, I'd still prefer to have a cleaner solution, so still thanks for your ideas. And I still would be happy about a solution concerning bold/plain for a whole paragraph.

[John Wilson]

You are using legacy code from version 2003 that is not intended to be used with 2010.

You need to use the new TextFrame2 object. This is easy in 2010 but a little broken in 2007

Try something like

Sub newMethod()
Dim oshp As Shape
Set oshp = ActiveWindow.Selection.ShapeRange(1)
With oshp.TextFrame2.TextRange
.Paragraphs(1).ParagraphFormat.FirstLineIndent = 10
.Paragraphs(1).ParagraphFormat.LeftIndent = 15
.Paragraphs(1).ParagraphFormat.Bullet.Type = msoBulletUnnumbered
.Paragraphs(2).ParagraphFormat.FirstLineIndent = 15
.Paragraphs(2).ParagraphFormat.LeftIndent = 20
.Paragraphs(2).ParagraphFormat.Bullet.Type = msoBulletUnnumbered
.Paragraphs(3).ParagraphFormat.FirstLineIndent = 20
.Paragraphs(3).ParagraphFormat.LeftIndent = 25
.Paragraphs(3).ParagraphFormat.Bullet.Type = msoBulletUnnumbered
End With
End Sub

[RandomGerman]

Okay, I'll have a try. Thank you, John.