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