1 Тема от Alex_Gur

  • Макросы для пропорционального изменения выделенного рисунка
  • Alex_Gur
  • Модератор
  • Неактивен
  • Откуда: Москва
  • Зарегистрирован: 28.07.2011
  • Сообщений: 2,758
  • Поблагодарили: 492

Тема: Макросы для пропорционального изменения выделенного рисунка

Простые макросы для пропорционального уменьшения и увеличения выделенного рисунка.

Данные макросы могут использоваться при подготовке технической документации для размещения большего количества рисунков на одной странице.

Уменьшение рисунка:

Sub ImageSizeMinus()
    Selection.InlineShapes(1).Height = Selection.InlineShapes(1).Height * 0.95
    Selection.InlineShapes(1).Width = Selection.InlineShapes(1).Width * 0.95
End Sub

Увеличение рисунка:

Sub ImageSizePlus()
    Selection.InlineShapes(1).Height = Selection.InlineShapes(1).Height * 1.05
    Selection.InlineShapes(1).Width = Selection.InlineShapes(1).Width * 1.05
End Sub
Удобной и приятной работы в Word!
Перевести спасибо на Яндекс кошелёк - 41001162202962; на WebMoney - R581830807057.

2 Ответ от Alex_Gur

  • Макросы для пропорционального изменения выделенного рисунка
  • Alex_Gur
  • Модератор
  • Неактивен
  • Откуда: Москва
  • Зарегистрирован: 28.07.2011
  • Сообщений: 2,758
  • Поблагодарили: 492

Re: Макросы для пропорционального изменения выделенного рисунка

В некоторых случаях бывает полезно очень незначительное ("точечное") изменение рисунка. Для этого можно указать коэффициент с малым отклонение от 1 (например, изменение на 0,5% - 0,995 и 1,005).

Незначительное уменьшение рисунка (на 0,5%):

Sub ImageSizeMinus()
    Selection.InlineShapes(1).Height = Selection.InlineShapes(1).Height * 0.995
    Selection.InlineShapes(1).Width = Selection.InlineShapes(1).Width * 0.995
End Sub

Незначительное увеличение рисунка (на 0,5%):

Sub ImageSizePlus()
    Selection.InlineShapes(1).Height = Selection.InlineShapes(1).Height * 1.005
    Selection.InlineShapes(1).Width = Selection.InlineShapes(1).Width * 1.005
End Sub
Удобной и приятной работы в Word!
Перевести спасибо на Яндекс кошелёк - 41001162202962; на WebMoney - R581830807057.

3 Ответ от sylvio

  • sylvio
  • сержант
  • Неактивен
  • Зарегистрирован: 19.03.2010
  • Сообщений: 37
  • Поблагодарили: 2

Re: Макросы для пропорционального изменения выделенного рисунка

Уважаемый Alex_Gur,
подскажите, пожалуйста, как через макрос вставить рисунок за текстом, при этом задать ему размеры страницы и выравнивание по странице? (это чтобы удостовериться, что форматирование текста совпадает с утвержденным отсканированным документом)

4 Ответ от sylvio

  • sylvio
  • сержант
  • Неактивен
  • Зарегистрирован: 19.03.2010
  • Сообщений: 37
  • Поблагодарили: 2

Re: Макросы для пропорционального изменения выделенного рисунка

уточняю: вставить из буфера

5 Ответ от Alex_Gur

  • Макросы для пропорционального изменения выделенного рисунка
  • Alex_Gur
  • Модератор
  • Неактивен
  • Откуда: Москва
  • Зарегистрирован: 28.07.2011
  • Сообщений: 2,758
  • Поблагодарили: 492

Re: Макросы для пропорционального изменения выделенного рисунка

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

Вот некоторые наметки, которые могут облегчить Вам написание данного макроса:

Sub Picture1()
    ' Вставляем рисунок из буфера обмена
    ' (в буфере обмена должен быть рисунок!)
    Selection.Paste
    With Selection.ShapeRange
        'Меняем центрирование
        .Align msoAlignCenters, True
            ' msoAlignBottoms   5   Align bottoms of specified objects.
            ' msoAlignCenters   1   Align centers of specified objects.
            ' msoAlignLefts     0   Align left sides of specified objects.
            ' msoAlignMiddles   4   Align middles of specified objects.
            ' msoAlignRights    2   Align right sides of specified objects.
            ' msoAlignTops  3   Align tops of specified objects.
        'Меняем обтекание
        .WrapFormat.Type = wdWrapBehind
            ' wdWrapInline  7   Places shapes in line with text.
            ' wdWrapNone    3   Places shape in front of text. See also wdWrapFront.
            ' wdWrapSquare  0   Wraps text around the shape. Line continuation is on the oposite side of the shape.
            ' wdWrapThrough 2   Wraps text around the shape.
            ' wdWrapTight   1   Wraps text close to the shape.
            ' wdWrapTopBottom   4   Places text above and below the shape.
            ' wdWrapBehind  5   Places shape behind text.
            ' wdWrapFront       6   Places shape in front of text.
        
        ' Перемещаем за текст
        .ZOrder msoSendBehindText
            ' msoBringForward   2   Bring shape forward.
            ' msoBringInFrontOfText 4   Bring shape in front of text.
            ' msoBringToFront   0   Bring shape to the front.
            ' msoSendBackward   3   Send shape backward.
            ' msoSendBehindText 5   Send shape behind text. (за текстом)
            ' msoSendToBack     1   Send shape to the back.
    End With
End Sub
Удобной и приятной работы в Word!
Перевести спасибо на Яндекс кошелёк - 41001162202962; на WebMoney - R581830807057.

6 Ответ от sylvio

  • sylvio
  • сержант
  • Неактивен
  • Зарегистрирован: 19.03.2010
  • Сообщений: 37
  • Поблагодарили: 2
  • За сообщение: 1

Re: Макросы для пропорционального изменения выделенного рисунка

Большое спасибо за совет.
Вот какой макрос получился

Sub pic_behind_text()
Application.ScreenUpdating = False
    Selection.Paste
    With Selection.ShapeRange
        .WrapFormat.Type = wdWrapBehind
        .LockAspectRatio = True
        .RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
        .Left = 0
        .RelativeVerticalPosition = wdRelativeVerticalPositionPage
        .Top = 0
        .Width = ActiveDocument.PageSetup.PageWidth
    End With
Application.ScreenUpdating = True
End Sub

Периодически макрос выдает ошибку Run-time error ‘4605’ The type method or property is not available because the drawing operation cannot be applied to the current selection.. Похоже, Word теряет выделение вставленного рисунка. Это как-то можно решить?

7 Ответ от Alex_Gur

  • Макросы для пропорционального изменения выделенного рисунка
  • Alex_Gur
  • Модератор
  • Неактивен
  • Откуда: Москва
  • Зарегистрирован: 28.07.2011
  • Сообщений: 2,758
  • Поблагодарили: 492

Re: Макросы для пропорционального изменения выделенного рисунка

Добрый день,

Попробуйте так:

Sub pic_behind_text()
    Application.ScreenUpdating = False
    Selection.Paste
    If (Selection.Type <> 8 And Selection.Type <> 7) Then
        Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
    End If
    
    With Selection.ShapeRange
        .WrapFormat.Type = wdWrapBehind
        .LockAspectRatio = True
        .RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
        .Left = 0
        .RelativeVerticalPosition = wdRelativeVerticalPositionPage
        .Top = 0
'        .Width = ActiveDocument.PageSetup.PageWidth
        .Align msoAlignCenters, True

    End With
    Application.ScreenUpdating = True
End Sub
Удобной и приятной работы в Word!
Перевести спасибо на Яндекс кошелёк - 41001162202962; на WebMoney - R581830807057.

8 Ответ от sylvio

  • sylvio
  • сержант
  • Неактивен
  • Зарегистрирован: 19.03.2010
  • Сообщений: 37
  • Поблагодарили: 2

Re: Макросы для пропорционального изменения выделенного рисунка

Спасибо большое, проверил.
Работает в Word 2010 на файлах docx, если курсор не в таблице (в этом случае рисунок и не выравнивается как надо, если выполнить макрос без Selection.Paste),
а вот в режиме совместимости (.doc) выдает новую ошибку 4198.

Если заменить Selection.Paste на Selection.PasteSpecial datatype:=wdPasteEnhancedMetafile, тогда в режиме совместимости появляестя старая ошибка 4605, то есть Word все так же теряет выделение.

9 Ответ от Alex_Gur

  • Макросы для пропорционального изменения выделенного рисунка
  • Alex_Gur
  • Модератор
  • Неактивен
  • Откуда: Москва
  • Зарегистрирован: 28.07.2011
  • Сообщений: 2,758
  • Поблагодарили: 492

Re: Макросы для пропорционального изменения выделенного рисунка

Оказывается, в форматах DOC и DOCX рисунки вставляются по-разному! Об этом никогда не задумывался.

Следующий код, кажется, работает и там, и там:

Sub pic_behind_text()
    Application.ScreenUpdating = False
    Selection.PasteSpecial Link:=False, DataType:=8

    With Selection.ShapeRange
        .WrapFormat.Type = wdWrapBehind
        .LockAspectRatio = True
        .RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
        .Left = 0
        .RelativeVerticalPosition = wdRelativeVerticalPositionPage
        .Top = 0
        .Align msoAlignCenters, True

    End With
    Application.ScreenUpdating = True
End Sub

если курсор не в таблице...

Это уже слишком сложный случай. Будем исходить из того, что курсор находится не в таблице.

Удобной и приятной работы в Word!
Перевести спасибо на Яндекс кошелёк - 41001162202962; на WebMoney - R581830807057.

10 Ответ от sylvio

  • sylvio
  • сержант
  • Неактивен
  • Зарегистрирован: 19.03.2010
  • Сообщений: 37
  • Поблагодарили: 2

Re: Макросы для пропорционального изменения выделенного рисунка

Выдет run-time error 5342 на docx и doc.
Если меняю DataType на 3, работает в docx, а в doc выдает 4605.
Перебрал все типы от 0 до 10 - безрезультатно для doc.