Bdtjtk

I'm currently trying to split a large chunk of text into tweets (it's an ebook I'm tweeting). I've got the code to split it into 280 character chunks, but I want it to end each tweet on a period (full stop) if possible whilst remaining within the 280 character limit.

I'm fairly new to VBA so there may be a much easier way of doing this. At the moment it looks fine split into 280 character chunks for Twitter, but I want it to read better by appearing as full sentences.

Sub SetLineLength()

'Requires setting reference to Microsoft VBScript Regular Expressions 5.5

'Will split at a space UNLESS a single word is longer than LineLength, in 

which

'case it will split at LineLength characters

Const LineLength As Long = 280

Dim RE As RegExp, MC As MatchCollection, M As Match

Dim Ps As Paragraphs, P As Paragraph

Dim i As Long

Dim doc As Document

Dim sIn As String, sOut As String

Set RE = New RegExp

RE.Global = True

Set doc = ActiveDocument



'Replace multiple spaces with one

'Leave paragraphs intact

'Trim to line length

Set Ps = doc.Paragraphs

For i = Ps.Count To 1 Step -1

Set P = Ps(i)

    RE.Pattern = "s{2,}"

sIn = RE.Replace(P.Range.Text, " ")

    RE.Pattern = "S.{0," & LineLength - 1 & "}(?=s|$)|S{" & LineLength & "}"

If RE.Test(sIn) = True Then

    Set MC = RE.Execute(sIn)

    sOut = ""

    For Each M In MC

        sOut = sOut & M & vbNewLine

    Next M

    P.Range.Text = sOut

End If



'Uncomment for debugging

'    Stop



Next i



End Sub

Any help would be greatly appreciated!

You need InStrRev to find the position of the last period within the next 280 characters. Put into a loop and advancing the starting position by the last found period with Mid should split up the paragraph into <=280 character pieces.

Option Explicit



Sub tweetThis()



    Dim p As Paragraph, doc As Document

    Dim i As Long, prd As Long, str As String



    Const ll As Long = 280

    ReDim tw(0) As Variant



    Set doc = ActiveDocument



    For Each p In doc.Paragraphs



        str = p.Range.Text & Space(ll)

        prd = InStrRev(str, Chr(46), ll, vbBinaryCompare)



        Do While prd > 0

            ReDim Preserve tw(i)

            tw(i) = Trim(Mid(str, 1, prd))

            i = i + 1

            str = Mid(str, prd + 1)

            prd = InStrRev(str, Chr(46), ll, vbBinaryCompare)

        Loop



    Next p



    For i = LBound(tw) To UBound(tw)

        Debug.Print tw(i)

    Next i



End Sub

You might try something based on:

Sub TextSplitter()

Dim Rng As Range

Application.ScreenUpdating = False

With ActiveDocument

  .Fields.Unlink

  Set Rng = .Range(0, 0)

  Do While Rng.End < .Range.End - 1

    With Rng

      .MoveEnd wdCharacter, 280

      ' Check whether the last character is a punctuation mark, paragraph break or line break

      If Not .Characters.Last.Text Like "[.?!," & vbCr & Chr(11) & "]" Then

        ' Find the last preceding space

        .End = .Start + InStrRev(Rng.Text, " ")

        ' Find the last preceding punctuation mark, paragraph break or line break

        If InStr(.Text, ".") > 0 Then

          .End = .Start + InStrRev(.Text, ".") + 1

        ElseIf InStr(.Text, "?") > 0 Then

          .End = .Start + InStrRev(.Text, "?") + 1

        ElseIf InStr(.Text, "!") > 0 Then

          .End = .Start + InStrRev(.Text, "!") + 1

        ElseIf InStr(.Text, ",") > 0 Then

          .End = .Start + InStrRev(.Text, ",") + 1

        ElseIf InStr(Rng.Text, Chr(11)) > 0 Then

          .End = .Start + InStrRev(.Text, Chr(11))

        ElseIf InStr(Rng.Text, vbCr) > 0 Then

          .End = .Start + InStrRev(.Text, vbCr)

        End If

        .Characters.Last.Text = vbCr

      End If

      DoEvents

      .Collapse wdCollapseEnd

    End With

  Loop

End With

Set Rng = Nothing

Application.ScreenUpdating = True

End Sub

Do be aware that, with the above code where a range contains multiple punctuation marks, etc, the If/ElseIf hierarchy determines the splitting priority, which could result in later punctuation marks in the same range being overlooked.

The following code takes a different approach, simply looking for the last punctuation mark of any kind.

Sub TextSplitter()

Dim Rng As Range

Application.ScreenUpdating = False

With ActiveDocument

  .Fields.Unlink

  Set Rng = .Range(0, 0)

  Do While Rng.End < .Range.End - 1

    With Rng

      .MoveEnd wdCharacter, 280

      ' Check whether the last character is not a punctuation mark, paragraph break or manual line break

      If Not .Characters.Last.Text Like "[.?!," & vbCr & Chr(11) & "]" Then

        ' Find the last preceding space

        .End = .Start + InStrRev(.Text, " ") + 1

        ' Find the last preceding punctuation mark, paragraph break or line break

        With .Find

          .Text = "[.?!,^13^11]"

          .Replacement.Text = ""

          .Forward = False

          .Format = False

          .Wrap = wdFindStop

          .MatchWildcards = True

          .Execute

        End With

        If .Find.Found = True Then

          ' Test the found character. If it's not a paragraph break, extend the range one character

          If .Characters.Last.Text <> vbCr Then

           If .Characters.Last.Text Like "[.?!,]" Then .End = .End + 1

          End If

        End If

        ' Replace the new last character with a paragraph break

        .Characters.Last.Text = vbCr

      ' The Find was unsuccessful, so retest the last character for a line break

      ElseIf .Characters.Last.Text = Chr(11) Then

        ' The last character is a manual line break, replace it with a paragraph break

        .Characters.Last.Text = vbCr

      Else

        ' The last character is a manual line break, so extend the range one character and

        ' replace the new last character with a paragraph break

        .End = .End + 1

        .Characters.Last.Text = vbCr

      End If

      DoEvents

      .Collapse wdCollapseEnd

    End With

  Loop

End With

Set Rng = Nothing

Application.ScreenUpdating = True

End Sub