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

13675

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.