В VBA ищем способ разбить большой кусок текста в MS Word, чтобы он заканчивался точкой И, если его длина не превышает 280 символов.

Question

В настоящее время я пытаюсь разбить большой кусок текста на твиты (это твиттер, который я пишу).У меня есть код для разбиения его на порции по 280 символов, но я хочу, чтобы он завершал каждый твит на период (полная остановка), если это возможно, оставаясь в пределах ограничения в 280 символов.

Я довольно новичокдля VBA, так что может быть гораздо проще сделать это.На данный момент он выглядит прекрасно, разделенным на 280 символов для Twitter, но я хочу, чтобы он читался лучше, отображаясь как полные предложения.

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

Любая помощь будет принята с благодарностью!

Answer 1

Вы можете попробовать что-то на основе:

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

Имейте в виду, что с помощью приведенного выше кода, где диапазон содержит несколько знаков препинания и т. Д., Иерархия If / ElseIf определяет приоритет разделения, что можетприводят к тому, что более поздние знаки препинания в том же диапазоне игнорируются.

Следующий код использует другой подход, просто ищет последний знак препинания любого вида.

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

Answer 2

Вам нужен InStrRev, чтобы найти позицию последнего периода в течение следующих 280 символов.Поместите в цикл, и продвижение начальной позиции на последний найденный период с Mid должно разделить абзац на <= 280 символов. </p>

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