Отправляет email-рассылки с помощью сервиса Sendsay

VBA tips - подсказки и решения на VBA

Рассылка закрыта

При закрытии подписчики были переданы в рассылку "Свой Бизнес" на которую и рекомендуем вам подписаться.

Вы можете найти рассылки сходной тематики в Каталоге рассылок.

←   Ноябрь 2009   →
 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
25.11.2009
11:11:13
12:06:42
26
27
28
29
30
Автор
alex.viter

Статистика

522 подписчиков
0 за неделю
←   Все выпуски   →

Печать цветных и чёрно-белых страниц на разные принтеры, обновление стилей во всех формулах MS Equation


Печать цветных и чёрно-белых страниц на разные принтеры

Такая проблема довольно часто возникает при печати документов, содержащих как текст, так и цветные рисунки, диаграммы и прочие графические объекты. Часто в офисах за чёрно-белую печать отвечает один принтер, а за цветную — другой. Можно ли автоматизировать процесс печати так, чтобы вручную не выбирать диапазоны страниц для печати на чёрно-белый и на цветной принтеры?

Отчасти мне удалось решить эту задачу таким макросом:


1 Sub SeparatePrint() 2 Const PRINTER_BW = "Принтер чернобелой печати" 3 Const PRINTER_COLOR = "Принтер цветной печати" 4 Dim sBWPages As String 'Строка для номеров страниц на ч\б печать 5 Dim sColorPages As String 'Строка для номеров страниц на цветную печать 6 Dim oDoc As Document: Set oDoc = ActiveDocument 'Документ, который нужно распечатать 7 Dim nPage As Long: nPage = 1 'Номер страницы 8 Dim oPageRng As Range 'Диапазон отдельной страницы 9 Dim nPages As Long: nPages = oDoc.Range.ComputeStatistics(wdStatisticPages) 'Количество страниц в документе 10 Do 11 'Переходим в начало отдельной страницы 12 Set oPageRng = oDoc.Range.GoTo(wdGoToPage, wdGoToAbsolute, nPage) 13 'Растягиваем диапазон на всю страницу 14 If nPage < nPages Then 15 oPageRng.SetRange oPageRng.Start, oDoc.Range.GoTo(wdGoToPage, wdGoToAbsolute, nPage + 1).Start 16 Else 17 oPageRng.SetRange oPageRng.Start, oDoc.Range.End 18 End If 19 20 If oPageRng.InlineShapes.Count = 0 And oPageRng.ShapeRange.Count = 0 Then 'Если нет рисунков 21 sBWPages = sBWPages & nPage & "," 'Добавляем в список страниц для печати на ч\б принтер 22 Else 'Если есть рисунки 23 sColorPages = sColorPages & nPage & "," 'Добавляем в список страниц для печати на цветной принтер 24 End If 25 nPage = nPage + 1 26 Loop While nPage <= nPages 27 sBWPages = Left(sBWPages, Len(sBWPages) - 1) 28 sColorPages = Left(sColorPages, Len(sColorPages) - 1) 29 ActivePrinter = PRINTER_BW 'Задаем ч\б принтер 30 'Отправляем на печать ч\б страницы 31 oDoc.PrintOut Range:=wdPrintRangeOfPages, Pages:=sBWPages 32 '------------------------------------------------------------------ 33 'Делаем задержку, пока задание на печать ещё не выполнено 34 Do 35 DoEvents 36 Loop While Application.BackgroundPrintingStatus > 0 37 '------------------------------------------------------------------ 38 ActivePrinter = PRINTER_COLOR 'Задаем цветной принтер 39 'Отправляем на печать цветные страницы 40 oDoc.PrintOut Range:=wdPrintRangeOfPages, Pages:=sColorPages 41 End Sub

Имена принтеров задаются в константах PRINTER_BW и PRINTER_COLOR.

Этот макрос не лишён недостатков. На цветную печать отправляются все страницы, на которых есть графические объекты. При этом совершенно не принимается во внимание, что могут быть формулы, которые нужно печатать на чёрно-белый принтер. Также на странице может быть цветной текст, но не быть графических объектов. А значит и эту страницу нужно печатать на цветной принтер.

Доработку макроса под конкретные нужды я оставляю на совести читателей.

Обновление стилей во всех формулах MS Equation

Иногда случается, что при многократном редактировании формул MS Equation они начинают выглядет по-разному: различаются величины символов, начертание и т.д. Если формул немного, то исправить это относительно легко: нужно зайти в любую формулу и настроить её так, как необходимо. Чтобы обновить остальные формулы, их просто нужно  открыть и закрыть. Но если формул много, то даже эта нетрудная операция, становится очень утомительной. К счастью, эту процеудуру можно автоматизировать таким макросом:

 

1 Sub UpdateMSEquation() 2 Dim oInShp As InlineShape 3 4 For Each oInShp In ActiveDocument.InlineShapes 5 'Если это формула, то открываем ее для редактирования 6 If oInShp.OLEFormat.ClassType = "Equation.3" Then oInShp.OLEFormat.DoVerb -5 7 Next 8 End Sub
В избранное