Комментатор 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.

контакты

 
^ Наверх