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

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

Самиздат: [Регистрация] [Найти] [Рейтинги] [Обсуждения] [Новинки] [Обзоры] [Помощь|Техвопросы]
Ссылки:
Школа кожевенного мастерства: сумки, ремни своими руками
 Ваша оценка:
  • Аннотация:
    Макросы для 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
     Next
   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
   Next
   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

  
  

 Ваша оценка:

Связаться с программистом сайта.

Новые книги авторов СИ, вышедшие из печати:
О.Болдырева "Крадуш. Чужие души" М.Николаев "Вторжение на Землю"

Как попасть в этoт список

Кожевенное мастерство | Сайт "Художники" | Доска об'явлений "Книги"