Increasing different line spacing at the same time

[RandomGerman]

Hi there,

I have two macros giving me quick control on the line spacing of text. One is to increase it (Sub SpacingPlus), the other one to set it back to 1.0 (Sub SpacingBackToOnePointZero). Most of the time they both work fine, but there is one exception. Imagine a shape with 4 lines of text. The first 2 lines have 0.8 line spacing, the last 2 lines have 1.2 line spacing. When I want to set all of them back to 1.0 (e. g., by selecting the whole text in the shape) it works. But when I want to keep the difference in the spacing and increase it all 4 lines + 0.1 (e. g., by selecting the whole text in the shape), I get an error. As both macros are composed the same way, I can not really figure out, why one is doing the work and the other one is not. I'd be glad, if someone is able to show me how to repair the first one (Sub SpacingPlus). Thank you!


Sub SpacingPlus()
Dim Shp As Shape
Dim oTbl As Table
Dim x As Long
Dim y As Long

On Error GoTo err

If ActiveWindow.Selection.Type = ppSelectionNone Then 'Nothing!
ElseIf ActiveWindow.Selection.Type = ppSelectionText Then
With ActiveWindow.Selection.TextRange
.ParagraphFormat.SpaceWithin = .ParagraphFormat.SpaceWithin + 0.1
End With
Else
For Each Shp In ActiveWindow.Selection.ShapeRange
If ActiveWindow.Selection.ShapeRange(1).HasTable Then
Set oTbl = ActiveWindow.Selection.ShapeRange.Table
For x = 1 To oTbl.Rows.Count
For y = 1 To oTbl.Columns.Count
If oTbl.Cell(x, y).Selected Then
With oTbl.Cell(x, y).Shape.TextFrame2.TextRange
.ParagraphFormat.SpaceWithin = .ParagraphFormat.SpaceWithin + 0.1
End With
End If
Next
Next
Else
With Shp.TextFrame2.TextRange
.ParagraphFormat.SpaceWithin = .ParagraphFormat.SpaceWithin + 0.1
End With
End If
Next Shp
End If
Exit Sub
err:
MsgBox "Error Message"
End Sub



Sub SpacingBackToOnePointZero()
Dim Shp As Shape
Dim oTbl As Table
Dim x As Long
Dim y As Long

On Error GoTo err

If ActiveWindow.Selection.Type = ppSelectionNone Then 'Nothing!
ElseIf ActiveWindow.Selection.Type = ppSelectionText Then
With ActiveWindow.Selection.TextRange
.ParagraphFormat.SpaceWithin = 1
End With
Else
For Each Shp In ActiveWindow.Selection.ShapeRange
If ActiveWindow.Selection.ShapeRange(1).HasTable Then
Set oTbl = ActiveWindow.Selection.ShapeRange.Table
For x = 1 To oTbl.Rows.Count
For y = 1 To oTbl.Columns.Count
If oTbl.Cell(x, y).Selected Then
With oTbl.Cell(x, y).Shape.TextFrame2.TextRange
.ParagraphFormat.SpaceWithin = 1
End With
End If
Next
Next
Else
With Shp.TextFrame2.TextRange
.ParagraphFormat.SpaceWithin = 1
End With
End If
Next Shp
End If
Exit Sub
err:
MsgBox "Error Message"
End Sub


Unfortunately it is not possible to use these macros (both of them) on two tables or a table and other shapes at the same time, too, but this is not that important.

[John Wilson]

You are trying to select several paragraphs and set them to DIFFERENT values This is impossible. Substitute something like:


If ActiveWindow.Selection.Type = ppSelectionNone Then 'Nothing!
ElseIf ActiveWindow.Selection.Type = ppSelectionText Then
With ActiveWindow.Selection.TextRange
For p = 1 To .Paragraphs.Count
.Paragraphs(p).ParagraphFormat.SpaceWithin = .Paragraphs(p).ParagraphFormat.SpaceWithin + 0.1
Next
End With
Else

[RandomGerman]

Brilliant as ever. Thank you, John, I owe you so much!

I copied this for a similar macro, concerning paragraphing, not line spacing. It works, but there is another strange thing going on: Sometimes - I haven't found out yet, when it's happening, it seems to happen randomly - the paragraphing is not increasing by 3 pt, but by 64,8 ... which is probably 3 lines. To avoid this, I added a rule for LineSpaceAfter, but it still happens from time to time. So I presume, I made a mistake. I haven't found it yet.


Sub ParaPlus()
Dim Shp As Shape
Dim oTbl As Table
Dim p As Long
Dim x As Long
Dim y As Long

On Error GoTo err

If ActiveWindow.Selection.Type = ppSelectionNone Then 'Nothing!
ElseIf ActiveWindow.Selection.Type = ppSelectionText Then
With ActiveWindow.Selection.TextRange
If .ParagraphFormat.LineRuleAfter = msoTrue Then .ParagraphFormat.LineRuleAfter = msoFalse
For p = 1 To .Paragraphs.Count
.Paragraphs(p).ParagraphFormat.SpaceAfter = .Paragraphs(p).ParagraphFormat.SpaceAfter + 3
Next
End With
Else
For Each Shp In ActiveWindow.Selection.ShapeRange
If ActiveWindow.Selection.ShapeRange(1).HasTable Then
Set oTbl = ActiveWindow.Selection.ShapeRange.Table
For x = 1 To oTbl.Rows.Count
For y = 1 To oTbl.Columns.Count
If oTbl.Cell(x, y).Selected Then
With oTbl.Cell(x, y).Shape.TextFrame2.TextRange
If .ParagraphFormat.LineRuleAfter = msoTrue Then .ParagraphFormat.LineRuleAfter = msoFalse
For p = 1 To .Paragraphs.Count
.Paragraphs(p).ParagraphFormat.SpaceAfter = .Paragraphs(p).ParagraphFormat.SpaceAfter + 3
Next
End With
End If
Next
Next
Else
With Shp.TextFrame2.TextRange
If .ParagraphFormat.LineRuleAfter = msoTrue Then .ParagraphFormat.LineRuleAfter = msoFalse
For p = 1 To .Paragraphs.Count
.Paragraphs(p).ParagraphFormat.SpaceAfter = .Paragraphs(p).ParagraphFormat.SpaceAfter + 3
Next
End With
End If
Next Shp
End If
Exit Sub
err:
MsgBox "Error message"
End Sub

[John Wilson]

I would try setting all three line rules (after, before & within) to count in points not lines but I know there is some weirdness in this code area which I don't fully understand

[RandomGerman]

I tried that. In most cases the macro sets paragraph after to 3 pt, but still once to lines, so it is obviously not the secure solution. AND, very strange, with all three rules included, the macro sets the line spacing to 0 - which is not part of the code at all. Really weird. So I better go back to what I posted in #3.

[John Wilson]

Looks to me that you should check whether line space is set to lines or points
If lines work out the likely spacing in points (1.2 * font size)
Set to points and increase the corrected figure.

Hope that makes sense (work through the code)


Sub format()
Dim trueSW As Single
Dim p As Long
With ActiveWindow.Selection.TextRange2
For p = 1 To .Paragraphs.Count
' if line space in lines calculate space in points
'assumes all text is same size in paragraph
If .Paragraphs(p).ParagraphFormat.LineRuleWithin = True Then
trueSW = .Paragraphs(p).Font.Size * 1.2
Else
trueSW = .Paragraphs(p).ParagraphFormat.SpaceWithin
End If
With .Paragraphs(p).ParagraphFormat
.LineRuleWithin = msoFalse
.SpaceWithin = trueSW + 3
End With
Next p
End With
End Sub

[RandomGerman]

I'll try what I can do with it. Thank you, John.

[RandomGerman]

After a long time without problems, today I received a slide with line spacing defined in pt, not in lines. The macro from #1 with John's edit from #2 ran into a similar trouble as the macro in #3 - reducing by 0.1 meant reducing by 0.1 pt, not 0.1 lines, as I hoped it would do.

After some experiments I hope I was able to fix it, until now any test worked well. I post it here, because it might be interesting for the forum, and of course, in case anyone discovers potential for optimization, please let me know. Once again thanks to John, because without his post #6 in this thread I would not have been able to create the solution below.



Sub LineSpaceDecNew()
Dim shp As Shape
Dim oTbl As Table
Dim p As Long
Dim x As Long
Dim y As Long
Dim oldPT As Single
Dim trueSW As Single
Dim factor As Single

On Error GoTo err

If ActiveWindow.Selection.Type = ppSelectionNone Then 'Nothing!
ElseIf ActiveWindow.Selection.Type = ppSelectionText Then
With ActiveWindow.Selection.TextRange2
For p = 1 To .Paragraphs.Count
If .Paragraphs(p).ParagraphFormat.LineRuleWithin = msoFalse Then
oldPT = .ParagraphFormat.SpaceWithin
factor = .Paragraphs(p).Font.Size * 1.2
trueSW = oldPT / factor
With .Paragraphs(p).ParagraphFormat
.LineRuleWithin = msoTrue
.SpaceWithin = trueSW - 0.1
End With
Else
trueSW = .Paragraphs(p).ParagraphFormat.SpaceWithin
With .Paragraphs(p).ParagraphFormat
.LineRuleWithin = msoTrue
.SpaceWithin = trueSW - 0.1
End With
End If
Next p
End With
Else
For Each shp In ActiveWindow.Selection.ShapeRange
If ActiveWindow.Selection.ShapeRange(1).HasTable Then
Set oTbl = ActiveWindow.Selection.ShapeRange.Table
For x = 1 To oTbl.Rows.Count
For y = 1 To oTbl.Columns.Count
If oTbl.Cell(x, y).Selected Then
With oTbl.Cell(x, y).Shape.TextFrame2.TextRange
For p = 1 To .Paragraphs.Count
If .Paragraphs(p).ParagraphFormat.LineRuleWithin = msoFalse Then
oldPT = .ParagraphFormat.SpaceWithin
factor = .Paragraphs(p).Font.Size * 1.2
trueSW = oldPT / factor
With .Paragraphs(p).ParagraphFormat
.LineRuleWithin = msoTrue
.SpaceWithin = trueSW - 0.1
End With
Else
trueSW = .Paragraphs(p).ParagraphFormat.SpaceWithin
With .Paragraphs(p).ParagraphFormat
.LineRuleWithin = msoTrue
.SpaceWithin = trueSW - 0.1
End With
End If
Next p
End With
End If
Next
Next
Else
With shp.TextFrame2.TextRange
For p = 1 To .Paragraphs.Count
If .Paragraphs(p).ParagraphFormat.LineRuleWithin = msoFalse Then
oldPT = .ParagraphFormat.SpaceWithin
factor = .Paragraphs(p).Font.Size * 1.2
trueSW = oldPT / factor
With .Paragraphs(p).ParagraphFormat
.LineRuleWithin = msoTrue
.SpaceWithin = trueSW - 0.1
End With
Else
trueSW = .Paragraphs(p).ParagraphFormat.SpaceWithin
With .Paragraphs(p).ParagraphFormat
.LineRuleWithin = msoTrue
.SpaceWithin = trueSW - 0.1
End With
End If
Next p
End With
End If
Next shp
End If
Exit Sub
err:
MsgBox "tbd"
End Sub