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

Петр Васильевич Путенихин

Макросы для Word и Excel - преобразования шрифтов, автоустановка ссылок в оглавлениях; изменение размеров рисунков

Содержание:

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

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

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

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


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


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

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

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

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

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

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

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

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

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

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

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

'

' lim84 Мaкрос

'

'

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

'

'

For i = 1 To 1000

Selection.TypeText Text:="<a href="#l"" & 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:="return"

'Selection.Find.ClearFormatting

'Selection.Find.Replacement.ClearFormatting

With Selection.Find

.Text = replasetext

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

'^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

Next

End Sub


'Текст макроса в формате "как есть" в тегах <xmp> Sub lim84() ' ' lim84 Макрос ' ' создан вручную копированием из lim85 Макрос ' For i = 1 To 1000 Selection.TypeText Text:="" 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:="return" With Selection.Find .Text = replasetext .Replacement.Text = "