Комментатор 63

Дата регистрации: 2010-11-20 23:01:17

Комментариев: 2

Редактировать персональные данные


Его последние комментарии:

  • Удаление лишних абзацев: очередной макрос
    2010-11-22 09:16:41
    Rem © Сачков Вадим Викторович. 20.11.2010
    Sub CleanEmptyPar()
    Rem Макрос удаляет лишние знаки абзацев внутри смысловых абзацев.
    Rem Также удаляет пустые абзацы, красные строки и двойные пробелы.
    Rem ВНИМАНИЕ!!! Удаляется также форматирование текста
    Rem Для корректной работы макроса смысловые абзацы должны быть разделены пустой строкой
    Rem или красной строкой,состоящей, как минимум, из двух пробелов.
        Rem получает количество символов в обработанной строке.
        Dim rez As Long
        
        Rem строка, состоящая из всего обрабатываемого текста
        Dim str As String
        
        Rem сохранение всего текста из word в переменную в str
        str = ActiveDocument.Content.Text
        
        Rem каждая нижеследующая функция меняет содержимое str
        
        Rem удаление знаков chr(10) после chr(13)
        rez = DelChar10(str)
        Rem Удаление знаков абзацев внутри параграфов.
        rez = DelExcessPar(str)
        Rem Удаление пробелов в начале параграфов
        rez = DelSpaceInBeginPar(str)
        Rem Удаление пустых абзацев
        rez = DelEmptyPar(str)
        Rem Удаление двойных пробелов
        rez = DelDoubleSpace(str)
        Rem вывод обработанного текста обратно в Word
        ActiveDocument.Content.Text = str
    End Sub
    Private Function DelChar10(ByRef str As String) As Long
    Rem удаление знаков chr(10) после chr(13)
        
        Rem позиция в str найденной подстроки в тексте
        Dim i As Long
        
        Rem позиция в str, до которой изменненый текст сохранен в strnew
        Dim j As Long
        
        Rem строка для сохранения изменённого текста
        Dim strnew As String
        
        strnew = ""
        i = 1
        j = 1
        Do
            i = InStr(i, str, Chr(10))
            If i = 0 Then
                strnew = strnew & Mid(str, j, Len(str) - j + 1)
                Exit Do
            End If
            strnew = strnew & Mid(str, j, i - j)
            i = i + 1
            j = i
        Loop
        str = strnew
        DelChar10 = Len(str)
    End Function
    Private Function DelExcessPar(ByRef str As String) As Long
    Rem Удаление знаков абзацев внутри параграфов.
    Rem Конец параграфа определяется или последующей пустой строкой,
    Rem или последующей красной строкой состоящей, как минимум, из двух пробелов
        Rem позиция в str найденной подстроки в тексте
        Dim i As Long
        
        Rem позиция в str, до которой изменненый текст сохранен в strnew
        Dim j As Long
        
        Rem строка для сохранения изменённого текста
        Dim strnew As String
        
        Rem строка состоящая из 2 пробелов для определения красной строки
        Dim strspace As String
        strspace = "  "
        
        strnew = ""
        i = 0
        If Mid(str, 1, 1) = Chr(13) Then i = i + 1
        j = i + 1
        Do
            i = InStr(i + 1, str, Chr(13))
            If i = 0 Then
                strnew = strnew & Mid(str, j, Len(str) - j + 1)
                Exit Do
            End If
            If Mid(str, i + 1, Len(strspace))  strspace Then
                If Mid(str, i - 1, 1)  Chr(13) And Mid(str, i + 1, 1)  Chr(13) Then
                    strnew = strnew & Mid(str, j, i - j) & " "
                    j = i + 1
                End If
            End If
        Loop
        str = strnew
        DelExcessPar = Len(str)
    End Function
    Private Function DelSpaceInBeginPar(ByRef str As String) As Long
    Rem Удаление пробелов в начале параграфов, т.е. пробелы после знаков chr(13)
        
        Rem позиция в str найденной подстроки в тексте
        Dim i As Long
        
        Rem позиция в str, до которой изменненый текст сохранен в strnew
        Dim j As Long
        
        Rem строка для сохранения изменённого текста
        Dim strnew As String
        
        strnew = ""
        i = 1
        j = 1
        Do While (Mid(str, i, 1) = " ")
            i = i + 1
            j = i
        Loop
        
        Do
            i = InStr(i, str, Chr(13))
            If i = 0 Then
                strnew = strnew & Mid(str, j, Len(str) - j + 1)
                Exit Do
            End If
            
            If Mid(str, i + 1, 1) = " " Then
                strnew = strnew & Mid(str, j, i - j + 1)
                i = i + 2
                j = i
                
                Do While (Mid(str, i, 1) = " ")
                    i = i + 1
                    j = i
                Loop
                    
            Else
                i = i + 1
            End If
        Loop
        
        str = strnew
        DelSpaceInBeginPar = Len(str)
    End Function
    Private Function DelEmptyPar(ByRef str As String) As Long
    Rem Удаление пустых абзацев
        Rem позиция в str найденной подстроки в тексте
        Dim i As Long
        
        Rem позиция в str, до которой изменненый текст сохранен в strnew
        Dim j As Long
        
        Rem строка для сохранения изменённого текста
        Dim strnew As String
        
        strnew = ""
        i = 1
        j = 1
        Do
            i = InStr(i, str, Chr(13))
            If i = 0 Then
                strnew = strnew & Mid(str, j, Len(str) - j + 1)
                Exit Do
            End If
            
            If Mid(str, i + 1, 1) = Chr(13) Then
                strnew = strnew & Mid(str, j, i - j + 1)
                i = i + 2
                j = i
                Do
                    If Mid(str, i, 1) = Chr(13) Then
                        i = i + 1
                        j = i
                    Else
                        Exit Do
                    End If
                Loop
            Else
                i = i + 1
            End If
        Loop
        str = strnew
        
        DelEmptyPar = Len(str)
        
    End Function
    Private Function DelDoubleSpace(ByRef str As String) As Long
    Rem Удаление двойных пробелов
        
        Rem позиция в str найденной подстроки в тексте
        Dim i As Long
        
        Rem позиция в str, до которой изменненый текст сохранен в strnew
        Dim j As Long
        
        Rem строка для сохранения изменённого текста
        Dim strnew As String
        strnew = ""
        i = 1
        j = 1
        Do
            i = InStr(i, str, " ")
            If i = 0 Then
                strnew = strnew & Mid(str, j, Len(str) - j + 1)
                Exit Do
            End If
            
            If Mid(str, i + 1, 1) = " " Then
                strnew = strnew & Mid(str, j, i - j + 1)
                i = i + 2
                j = i
                Do
                    If Mid(str, i, 1) = " " Then
                        i = i + 1
                        j = i
                    Else
                        Exit Do
                    End If
                Loop
            Else
                i = i + 1
            End If
        Loop
        str = strnew
                
        DelDoubleSpace = Len(str)
        
    End Function
    Private Function AddChar10(ByRef str As String) As Long
    Rem возвращение знаков chr(10) после chr(13)
        
        Rem позиция в str найденной подстроки в тексте
        Dim i As Long
        
        Rem позиция в str, до которой изменненый текст сохранен в strnew
        Dim j As Long
        
        Rem строка для сохранения изменённого текста
        Dim strnew As String
        
        strnew = ""
        i = 1
        j = 1
        Do
            i = InStr(i, str, Chr(13))
            If i = 0 Then
                strnew = strnew & Mid(str, j, Len(str) - j + 1)
                Exit Do
            End If
            If i = Len(str) Or Mid(str, i + 1, 1)  Chr(10) Then strnew = strnew & Mid(str, j, i - j + 1) & Chr(10)
            i = i + 1
            j = i
        Loop
        str = strnew
        AddChar10 = Len(str)
    End Function
  • Удаление лишних абзацев: очередной макрос
    2010-11-20 23:01:17

    У вышеперечисленного макроса есть самый главный недостаток. Это просто адская медлительность. Если ваш текст занимает десятки страниц, то смело идите курить. А если сотни страниц, то ждать будете десятки минут.

    Сам занялся задачей удаления лишних знаков абзацев в параграфах. Качал книги с lib.ru и исправлял текст примерно, как сказано у Сереги.

    Потом стало лениво и решил написать макрос.

    Получился примерно как в шапке и столкнулся с медлительностью. Поэтому написав пару разных вариантов, убыстряя алгоритм, остановился на том , который дам ниже.

    Размер макроса несоизмеримо больше и намного сложнее вышеуказаного. Текст макроса подробно комментирован.

    Назначение:

    1) удаляет лишние знаки абзацев внутри текстовых (смысловых) абзацев

    2) удаляет пустые абзацы

    3) удаляет пробелы в начале абзацев

    4) удаляет двойные пробелы

    требования к тексту:

    1) текстовые (смысловые) абзацы должны быть разделены пустыми строками или, как минимум, двумя пробелами в начале абзацев , т.е. красными строками

    Преимущества:

    1) работает максимально быстро.

    Недостатки:

    1) убирает форматирование текста (это сделано для сверхбыстрой работы)

    сам макрос состоит из нескольких приватных функций и основной CleanEmptyPar.

^ Наверх