Объединить предложения в MS WORD

 

Sub ОбъединитьПредложения()
    Dim selectedText As String
    Dim resultText As String
    Dim i As Integer
    Dim char As String
    Dim nextChar As String
    Dim hasLeadingSpace As Boolean
    Dim hasTrailingSpace As Boolean
    Dim hasEndingPunctuation As Boolean
    
    ' Проверка наличия выделенного текста
    If Selection.Type = wdSelectionIP Then
        MsgBox "Пожалуйста, выделите текст для обработки.", vbExclamation, "Нет выделения"
        Exit Sub
    End If
    
    ' Получаем выделенный текст
    selectedText = Selection.Text
    
    ' Запоминаем, есть ли пробелы в начале и конце
    hasLeadingSpace = (Left(selectedText, 1) = " ")
    hasTrailingSpace = (Right(selectedText, 1) = " " Or Right(selectedText, 1) = vbCr)
    
    ' Проверяем, есть ли знак препинания в конце (до удаления пробелов)
    Dim tempText As String
    tempText = RTrim(selectedText)
    Dim lastChar As String
    If Len(tempText) > 0 Then
        lastChar = Right(tempText, 1)
        hasEndingPunctuation = (lastChar = "." Or lastChar = "?" Or lastChar = "!")
    Else
        hasEndingPunctuation = False
    End If
    
    ' Удаляем символы конца строки и параграфа, заменяя на пробел
    selectedText = Replace(selectedText, vbCrLf, " ")
    selectedText = Replace(selectedText, vbCr, " ")
    selectedText = Replace(selectedText, vbLf, " ")
    selectedText = Replace(selectedText, Chr(11), " ") ' Разрыв строки
    selectedText = Replace(selectedText, Chr(13), " ")
    
    ' Удаляем множественные пробелы
    Do While InStr(selectedText, "  ") > 0
        selectedText = Replace(selectedText, "  ", " ")
    Loop
    
    ' Убираем пробелы в начале и конце для обработки
    selectedText = Trim(selectedText)
    
    ' Обработка точек, вопросительных и восклицательных знаков
    resultText = ""
    i = 1
    
    Do While i <= Len(selectedText)
        char = Mid(selectedText, i, 1)
        
        ' Проверяем, является ли символ знаком конца предложения
        If char = "." Or char = "?" Or char = "!" Then
            ' Смотрим, что идёт после знака
            Dim j As Integer
            j = i + 1
            
            ' Пропускаем пробелы после знака
            Do While j <= Len(selectedText) And Mid(selectedText, j, 1) = " "
                j = j + 1
            Loop
            
            ' Проверяем, не последний ли это знак препинания
            If j <= Len(selectedText) Then
                ' Проверяем, есть ли буква после пробелов
                nextChar = Mid(selectedText, j, 1)
                
                ' Это не последний знак - удаляем его и пробелы после
                ' Делаем следующую букву строчной
                i = j - 1
                resultText = resultText & " " & LCase(nextChar)
                i = j
            Else
                ' Это последний знак - оставляем его
                resultText = resultText & char
            End If
        Else
            resultText = resultText & char
        End If
        
        i = i + 1
    Loop
    
    ' Удаляем множественные пробелы в результате
    Do While InStr(resultText, "  ") > 0
        resultText = Replace(resultText, "  ", " ")
    Loop
    
    resultText = Trim(resultText)
    
    ' Если в конце нет знака препинания, добавляем сохранённые пробелы
    If Not hasEndingPunctuation Then
        If hasLeadingSpace Then
            resultText = " " & resultText
        End If
        If hasTrailingSpace Then
            resultText = resultText & " "
        End If
    End If
    
    ' Заменяем выделенный текст на обработанный
    Selection.Text = resultText
    
End Sub