Комментатор 63
Дата регистрации: 2010-11-20 23:01:17
Комментариев: 2
Редактировать персональные данные
Его последние комментарии:
- Удаление лишних абзацев: очередной макрос
2010-11-22 09:16:41
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253Rem © Сачков Вадим Викторович. 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.