Путенихин Петр Васильевич. Макросы для Word и Excel

Содержание:

Макрос для создания ссылок в Оглавлении

Макрос для замены "крякозяб" из буфера

Макрос для создания шрифтов при копировании из pdf в doc

Таблица Excel для преобразования размеров рисунков на созданных html-страницах.

Макрос для создания ссылок в Оглавлении

Sub lim84() 'Макрос для установки ссылок в оглавлении

'Создаем Оглавление, состоящее из текстов заголовков разделов (глав)

'Строка в Оглавлении должна быть тождественна названию раздела (главы)

'В конце Оглавления добавляем строку (метку) 1234567. По её достижению

'процесс формирования ссылок прекращается

'Перед первой строкой Оглавления помещаем курсор и запускаем Макрос

'Теперь каждая строка Оглавления будет иметь вид

' <a href=""#" & i & """>Глава, в которой говорится о...</a>

'Каждая соответствующая одноименная Глава будет иметь вид:

'<a name=""" & i & """></a><b> Глава, в которой говорится о...</b>

'Где символ i = 1, 2, 3 ... 1000 соответствует номеру строки в Оглавлении

' lim84 Мaкрос

' создaн вручную копированием из lim85 Мaкрос

For i = 1 To 1000

Selection.TypeText Text:="<a href=""#" & i & """>"

Selection.EndKey Unit:=wdLine, Extend:=wdExtend

Selection.Copy

'тaким хитрым способом подменяем зaмену из буферa обменa

replasetext = Selection

'прекращаем преобразование, если встретим метку

metka = "1234567" & Chr(13)

'MsgBox ("Texxxxt - " & replasetext & " metka - " & metka) ' команда для отладки Макроса

If replasetext = metka Then Exit Sub

Selection.MoveRight Unit:=wdCharacter, Count:=1

Selection.MoveLeft Unit:=wdCharacter, Count:=1

Selection.TypeText Text:="</a>return"

'Selection.Find.ClearFormatting

'Selection.Find.Replacement.ClearFormatting

With Selection.Find

.Text = replasetext

.Replacement.Text = "<a name=""" & i & """></a><b> ^c</b>"

'^c - содержимое буфера обмена. Заполняется командой Selection.Copy

.Forward = True

.Wrap = wdFindContinue

.Format = False

.MatchCase = False

.MatchWholeWord = False

.MatchWildcards = False

.MatchSoundsLike = False

.MatchAllWordForms = False

End With

Selection.Find.Execute

With Selection

If .Find.Forward = True Then

.Collapse Direction:=wdCollapseStart

Else

.Collapse Direction:=wdCollapseEnd

End If

.Find.Execute Replace:=wdReplaceOne

If .Find.Forward = True Then

.Collapse Direction:=wdCollapseEnd

Else

.Collapse Direction:=wdCollapseStart

End If

.Find.Execute

End With

'Selection.Find.ClearFormatting

'Selection.Find.Replacement.ClearFormatting

With Selection.Find

'удаляем "хитрую" подмену буфера обмена

.Text = "return"

.Replacement.Text = ""

.Forward = True

' .Wrap = wdFindAsk

.Wrap = wdFindContinue

.Format = False

.MatchCase = False

.MatchWholeWord = False

.MatchWildcards = False

.MatchSoundsLike = False

.MatchAllWordForms = False

End With

Selection.Find.Execute

With Selection

If .Find.Forward = True Then

.Collapse Direction:=wdCollapseStart

Else

.Collapse Direction:=wdCollapseEnd

End If

.Find.Execute Replace:=wdReplaceOne

If .Find.Forward = True Then

.Collapse Direction:=wdCollapseEnd

Else

.Collapse Direction:=wdCollapseStart

End If

.Find.Execute

End With

Selection.EndKey Unit:=wdLine

Selection.MoveRight Unit:=wdCharacter, Count:=1

End Sub

'Текст макроса в формате "как есть" в тегах <xmp> Sub lim84() ' ' lim84 Макрос ' ' создан вручную копированием из lim85 Макрос ' For i = 1 To 1000 Selection.TypeText Text:="<a href=""#" & i & """>" Selection.EndKey Unit:=wdLine, Extend:=wdExtend Selection.Copy 'таким хитрым способом подменяем замену из буфера обмена replasetext = Selection 'прекращаем преобразование, если встретим метку metka = "1234567" & Chr(13) If replasetext = metka Then Exit Sub Selection.MoveRight Unit:=wdCharacter, Count:=1 Selection.MoveLeft Unit:=wdCharacter, Count:=1 Selection.TypeText Text:="</a>return" With Selection.Find .Text = replasetext .Replacement.Text = "<a name=""" & i & """></a><b> ^c</b>" .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute With Selection If .Find.Forward = True Then .Collapse Direction:=wdCollapseStart Else .Collapse Direction:=wdCollapseEnd End If .Find.Execute Replace:=wdReplaceOne If .Find.Forward = True Then .Collapse Direction:=wdCollapseEnd Else .Collapse Direction:=wdCollapseStart End If .Find.Execute End With With Selection.Find .Text = "return" .Replacement.Text = "" .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute With Selection If .Find.Forward = True Then .Collapse Direction:=wdCollapseStart Else .Collapse Direction:=wdCollapseEnd End If .Find.Execute Replace:=wdReplaceOne If .Find.Forward = True Then .Collapse Direction:=wdCollapseEnd Else .Collapse Direction:=wdCollapseStart End If .Find.Execute End With Selection.EndKey Unit:=wdLine Selection.MoveRight Unit:=wdCharacter, Count:=1 Next End Sub

Макрос для замены "крякозяб" из буфера

При копировании текста макроса Word или Excel кириллица (комментарии) превращается в нечитаемые коды. Макрос преобразует в документе Word такие символы в читаемые. Правда, после ряда экспериментов из Excel макросы стали копироваться корректно.

Sub Замена_символов00()

' Замена_символов00 Макрос

'В цикле просматриваем каждый нечитаемый символ, которые имеют коды 192-255

For i = 192 To 255

'Создаем шаблон правильной кодировки

Alphabet = "АБВГДЕЖЗИЙКЛМНОПРСТУФХЦЧШЩЪЫЬЭЮЯабвгдежзийклмнопрстуфхцчшщъыьэюя"

'Каждому значению переменной цикла соответствует правильный символ:

replacer = Mid(Alphabet, i - 191, 1) 'Вычитаем 191, поскольку в шаблоне нумерация с 1

'И символ не читаемый:

search = ChrW(i)

Selection.Find.ClearFormatting

Selection.Find.Replacement.ClearFormatting

With Selection.Find

'Находим символ не читаемый:

.Text = search

'И заменяем его на правильный:

.Replacement.Text = replacer

.Forward = True

.Wrap = wdFindContinue

.Format = False

.MatchCase = True

.MatchWholeWord = False

.MatchWildcards = False

.MatchSoundsLike = False

.MatchAllWordForms = False

End With

Selection.Find.Execute Replace:=wdReplaceAll

End Sub

Этот же макрос приводим в виде "как есть", просто копируя его текст из VBA Sub Замена_символов00() ' ' Замена_символов00 Макрос ' For i = 192 To 255 Alphabet = "АБВГДЕЖЗИЙКЛМНОПРСТУФХЦЧШЩЪЫЬЭЮЯабвгдежзийклмнопрстуфхцчшщъыьэюя" replacer = Mid(Alphabet, i - 191, 1) search = ChrW(i) Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = search .Replacement.Text = replacer .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = True .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute Replace:=wdReplaceAll Next End Sub

Макрос для создания шрифтов при копировании из pdf в doc

При копировании текстов из статей в pdf-формате в документы *doc текст копии нечитаем. В частности, это относится к статьям сайта УФН. Макрос позволяет изменить кодировку символов на вордовскую. Копируем текст из pdf в doc и запускаем макрос.

'Текст макроса в формате "как есть" в тегах <xmp> Sub a__Замена_символов02() ' ' Замена_символов00 Макрос Alphabet = "АБВГДЕЁЖЗИЙКЛМНОПРСТУФХЦЧШЩЪЫЬЭЮЯабвгдеёжзийклмнопрстуфхцчшщъыьэюя" For i = 161 To 226 replacer = Mid(Alphabet, i - 160, 1) search = ChrW(i) Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = search .Replacement.Text = replacer .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = True .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute Replace:=wdReplaceAll Next End Sub Excel

Таблица для преобразования размеров рисунков на созданных html-страницах.

Если необходимо в массовом порядке изменить размеры рисунков, то можно использовать следующую excel-таблицу.

Excel-table

Каждая строка содержит формулы для преобразования. Сначала необходимо заполнить первую колонку параметрами рисунка. Для этого на html-странице открываем свойства первого рисунка. Затем последовательно копируем параметры всех рисунков, не забывая записать и его номер. Параметры рисунка заносим в первую колонку, а его номер - в колонку F.

Сразу же после внесения параметров рисунка с html-страницы, появится строчка его размеров - колонка E. Если на странице размер рисунка нас не устраивает, то его можно изменить просто задав масштаб в колонке В (имя колонки М - масштаб). Колонки G-X - вспомогательные, их не нужно трогать.

Теперь копируем желтую область - колонки Е-F и копируем текст размера рисунка в его код на странице. В колонке L (имя колонки тоже М-масштаб) появится фактический масштаб, установленный на странице. Можно его сохранить, тогда изменений в код рисунка вносить не надо. В текстовом виде формулы в ячейках приведены в следующей таблице. Левая колонка - текст формулы для строки 2, правая - имя колонки на листе Excel. Остальные строки создаются простым протягиванием.

788px в 462px (в масштабе 615px в 360px)	A
=L2	B
=ОКРУГЛ(B2*H2;0)	C
=ОКРУГЛ(B2*I2;0)	D
="width="""&C2&""" height="""&D2&""""	E
1	F
	G
=ПСТР(A2;1;N2)+0	H
=ПСТР($A2;P2;R2)+0	I
=ПСТР($A2;S2;U2)+0	J
=ПСТР($A2;V2;X2)+0	K
=J2/H2	L
	M
=НАЙТИ( "px";$A2;1)-1	N
=N2	O
=НАЙТИ( "в ";$A2;O2)+2	P
=НАЙТИ( "px";$A2;P2-3)	Q
=Q2-P2	R
=НАЙТИ( "табе ";$A2;1)+5	S
=НАЙТИ( "px";$A2;S2)	T
=T2-S2	U
=НАЙТИ( "в ";$A2;P2+1)+2	V
=НАЙТИ( "px";$A2;V2)	W
=W2-V2	X

Комментарии: 1, последний от 17/10/2019. © Copyright Путенихин Петр Васильевич (pe_put@rambler.ru) Размещен: 04/11/2016, изменен: 08/09/2019. 22k. Статистика. Статья: Естествознание Памятки Иллюстрации/приложения: 1 шт. Скачать FB2		Ваша оценка:
Аннотация: Макросы для Word и Excel - преобразования шрифтов, автоустановка ссылок в оглавлениях; изменение размеров рисунков

Путенихин Петр Васильевич : другие произведения.

Макросы для Word и Excel