Статьи из блога
Макрос массового уменьшения размеров всех рисунков
Иван задал вопрос:
Есть документ Word с картинками (их много) и текстом. Необходимо "ужать" количество страниц. Уменьшить шрифт текста - понятно, но как уменьшить размер всех картинок одновременно, скажем, на 50%?
Сделать это можно с помощью следующего макроса:
Первый вариант:
Sub changeImages() Dim iShape As InlineShape For Each iShape In ActiveDocument.InlineShapes iShape.Height = iShape.Height * 0.5 iShape.Width = iShape.Width * 0.5 Next iShape End sub
Второй вариант для объектов класса Shape или InlineShape:
Sub changeImages2()
Dim pic As Object
On Error Resume Next
For Each pic In ActiveDocument.Content.InlineShapes
If pic.Type = wdInlineShapePicture Then
pic.Height = pic.Height / 2
pic.Width = pic.Width / 2
End If
Next
For Each pic In ActiveDocument.Content.ShapeRange
If pic.Type = msoPicture Then
pic.Height = pic.Height / 2
If pic.LockAspectRatio = msoFalse Then
pic.Width = pic.Width / 2
End If
End If
Next
End sub
Рубрика: Вопрос-Ответ, Макросы, Стили и форматирование
Метки: макросы | рисунки | форматирование
Просмотров: 39585
Подписаться на комментарии по RSS
Версия для печати
Метки: макросы | рисунки | форматирование
Просмотров: 39585
Подписаться на комментарии по RSS
Версия для печати
Еще записи по вопросам использования Microsoft Word:
- 10 вопросов и ответов по редактору Word (1 часть)
- 3 способа очистки списка недавно открытых документов
- Word 2007: добавляем свою вкладку и свои команды
- Word 2007: полотно, рисунки, линии
- Word 2007: смена формата сохранения файла
- Word 97 - решение проблемы с отображением символов на линейке
- Word 97. Слияние документов как один из способов упростить свою работу
- Абзац с цветным фоном
- Автозаполняемые колонтитулы
- Автоматизация текстового набора в Word
- Автоматическая запись макроса
- Автоматическая нумерация билетов
- Автоматическая расстановка переносов
- Автоматическое обновление полей при открытии документа
- Автоматическое сохранение документа при его закрытии
- Автотекст с последовательной нумерацией
- Автоформат документов
- Белый текст на синем фоне в Word 2007
- Буквица
- Быстрая смена ориентации страниц документа
- Быстрое изменение стиля форматирования текста
- Быстрое перемещение между открытыми документами Word
- Быстрое создание нового документа на основе шаблона
- Быстрое удаление границ у таблицы
- Быстрый ввод текста с помощью команды =rand()
Форум
Читают
Обсуждают
страницы
сайты
статистика
Комментариев: 22
Очень полезный макрос, спасибо за то, что не забываете о нас
ScannerDoctor
Пакет форматирования в MS Word отсканированных книг.
Разработано на платформе MS Office Word 2003 SP2.
Опробовано на документах полученных ABBYY FineReader 7-8.
Автор: Александр, alex-mail@tut.by, Брест, 2005-2007.
Скачать можно по адресу: http://alex-mail.at.tut.by/.
Надо найти поподробнее
Подскажите, будьте добры, что нужно изменить в этом макросе, чтобы он уменьшал размер рисунков не в процентах от исходного значения, а точно - в см?
Т.е. нужно, допустим, чтобы все рисунки были по высоте 12 см. А ширина чтобы изменилась автоматически пропорционально.
Могу предложить вариант для изменения выделенного графического объекта (не всех, а конкретного выделенного объекта).
Может кто предложить макрос для прохода по всем (!) графическим объектам?
Sub changeSizeImage() 'Изменение размера для выделенного графического объекта Dim hSp As Single Dim h As Single h = 12 On Error Resume Next With Selection Select Case .Type Case Word.WdSelectionType.wdSelectionInlineShape hSp = PointsToCentimeters(.InlineShapes(1).Height) If hSp > h Then .InlineShapes(1).Height = CentimetersToPoints(h) Case Word.WdSelectionType.wdSelectionShape hSp = PointsToCentimeters(.ShapeRange.Height) If hSp > h Then .ShapeRange.Height = CentimetersToPoints(h) Case Else MsgBox "Не графический объект" End Select End With End SubДля всех картинок (InlineShape):
Для всех рисунков (Shape), типа автофигур:
Антон, спасибо.
Только не могу понять одну вещь. Макрос правильно работает на новых вставляемых в документ рисунках, но не работает на уже вставленых и изменённых/отформатированных ранее. Вообще ничего не происходит. Сверил все настройки рисунков, вроде бы всё совпадает (на новых и старых).
А также первый макрос (changeSizeImage) нельзя использовать если одновременно выделить два и более рисунка. Часто нужно изменить не все рисунки в документе, а выделить несколько штук и изменить их размер.
Обратил внимание также, что это и вручную сделать нельзя - если выделить два и более рисунка, то в поля Высота/Ширина ничего нельзя ввести. Т.е. получается нельзя ничего сделать?
Вы просили:
Я предложил три варианта: первый работает только с выделенным одним объектом. Второй и третий вариант макроса работают с графическими объектами (всеми, имеющимися в документе).
Разумеется, для отдельных случаев использования нужно думать и менять.
Так, а размеры старых каковы?
Как вам это удается? Или они у вас идут друг за другом, то есть не разделены текстом? Но даже если и так, это два разных объекта.
"Так, а размеры старых каковы?"
Размеры любые могут быть. Отличные от 12 см.
"Как вам это удается? Или они у вас идут друг за другом, то есть не разделены текстом? Но даже если и так, это два разных объекта."
Да, действительно, выделить одновременно можно только 2 идущих подряд рисунка. Тогда вопрос отпадает.
P.S. как вставлять цитату здесь?
Используйте теги blockquote.
Я вот подумал, а если указывать номера нужных рисунков, чтобы именно их макрос и обрабатывал? У вас же наверное идут подрисуночные подписи? Там определены номера. Хотя можно и автоматически подсчитывать...
Впрочем, мне кажется, что все-таки удобнее последовательно выбирать нужный рисунок и применять к каждому макрос из комментария №5.
Да, подписи с номерами есть, но в разных разделах своя нумерация, и плюс она может идти даже не подряд. Так что смотря какие номера указывать. Ну в любом случае с указыванием номера будет не очень удобно. Так что пожалуй соглашусь, что при невозможности одноврменного выделения нескольких рисунков удобнее всего выделять по одному и применять к каждому макрос.
Спасибо.
Поправка: макросы Word работают только с одним, последовательным, последним из выделенных блоков. Т.е. невозможно выделить несколько блоков с рисунками, а в одном выделено блоке рисунков может быть сколько угодно.
Для масштабирования лучше использовать функции Shape.ScaleHeight и Shape.ScaleWidth.
Вот вариант макроса, позволяющий измерять масштаб всех рисунков в выделенной области:
Sub SetNewSizeImages() ' ' SetNewSizeImages Макрос ' Макрос создан 15.05.2010 Excellence ' ' Изменяет размер всех выделенных рисунков Dim iShape As InlineShape Dim iScale As Single iScale = InputBox("Укажите масштаб", "Изменение всех рисунков", "50") For Each iShape In Selection.InlineShapes iShape.ScaleHeight = iScale iShape.ScaleWidth = iScale Next iShape End SubА реально ли заставить макрос обрабатывать "горизонтальные" изображение по одному параметру, а "вертикальные" по другому?
Роман, это реально. Достаточно проанализировать соотношение сторон (Width и Height). Если Вас интересует что-то более конкретное, то приходите на форум, там и обсудим.
Вопрос: как сделать все картинки не более 8-9см? по горизонтали?
Благодарю вас, дамы и господа, вы сэкономили мне год жизни!
Коллеги, добрый день! подскажите пожалуйста, можно ли как-то в Макросе прописать так, чтобы он осуществлял изменения над изображением, которое находится на данном листе, просто у меня получается, что при удалении старого и вставлении нового изображения, наименование рисунка меняется с "Picture 1" на "Picture 2" и так далее, и макрос уже соответственно выдает ошибку.
Заранее спасибо! если непонятно объяснил, готов дополнить и скинуть код который получается..