Изменить размеры всех картинок в документе Word

От /

Вам передали файл Word со множеством разных картинок. Того, кто это сделал, как правило, не интересует разница между картинкой в 50, 500 и 5 000 пикс., гуманное отношение к размерам файла и дискового пространства, отличия в требованиях к вебу и, например, полиграфии.

Или вы скопипастили в Word длинную переписку из чата, в которой 300 раз повторяются БОЛЬШИЕ аватарки участников диалога.
Ctrl+H + ^g, скажите вы, но тогда все фото бесследно исчезнут, и линия диалога (кто спросил, а кто ответил) станет неочевидной.

Чтобы одним движением уменьшить в документе сразу все эти 300 фото, размер всех картинок сделать одинаковым, а пропорции не нарушить, используем макрос с заданием ширины и сохранением пропорций картинок:

Sub ResizeAllPicturesKeepAspectRatio()
    Dim img As InlineShape
    Dim targetWidthPx As Integer
    Dim pointsPerPixel As Double
    
    ' Вызываем окно и устанавливаем желаемую ширину в пикселях
    targetWidthPx = InputBox("Ведите ширину в пикселях", "Размеры картинки", 400) ' ширина в пикселях
    
    ' Коэффициент перевода
    pointsPerPixel = 72 / 96 ' 0.75 пунктов на пиксель
    
    ' Обрабатываем все изображения в документе
    For Each img In ActiveDocument.InlineShapes
        If img.Type = wdInlineShapePicture Then
            ' Сохраняем пропорции
            img.LockAspectRatio = msoTrue
            ' Устанавливаем ширину
            img.Width = targetWidthPx * pointsPerPixel
            ' Высота изменится автоматически
        End If
    Next img
    
    MsgBox "Размер всех изображений изменен с сохранением пропорций!", vbInformation
End Sub

Если что, напомним как добавить макрос и заставить его работать:

1) В Word нажать Alt + F11, вставить в окошко редактора скопированный выше код, нажать Ctrl + S и закрыть окно VBA (Alt + F4);

2) Нажать Alt + F8, выбрать макрос ResizeAllPicturesKeepAspectRatio и нажать кнопку Выполнить.

Вариант с жестким размером по ширине и высоте, без соблюдения пропорций:

Замените в коде ширину и высоту в пикселях

Sub ResizeAllPicturesInWord()
    Dim img As InlineShape
    Dim targetWidthPx As Integer
    Dim targetHeightPx As Integer
    Dim pointsPerPixel As Double
    
    ' Устанавливаем желаемый размер в пикселях
    targetWidthPx = 400 ' ширина в пикселях
    targetHeightPx = 300 ' высота в пикселях
    
    ' Коэффициент перевода пикселей в пункты (1 пункт = 1/72 дюйма)
    ' Стандартное разрешение: 96 пикселей на дюйм
    pointsPerPixel = 72 / 96 ' 0.75 пунктов на пиксель
    
    ' Обрабатываем все изображения в документе
    For Each img In ActiveDocument.InlineShapes
        If img.Type = wdInlineShapePicture Then
            ' Устанавливаем размер в пунктах (перевод из пикселей)
            img.Width = targetWidthPx * pointsPerPixel
            img.Height = targetHeightPx * pointsPerPixel
            
            ' Альтернативный вариант с сохранением пропорций
            ' img.LockAspectRatio = msoTrue
            ' img.Width = targetWidthPx * pointsPerPixel
            ' Высота изменится автоматически, сохраняя пропорции
        End If
    Next img
    
    MsgBox "Размер всех изображений изменен!", vbInformation
End Sub

Нажать Alt + F8, выбрать макрос ResizeAllPicturesInWord и нажать кнопку Выполнить.

Еще один вариант решения вопроса, но задаем не ширину в пикселях, а общий % уменьшения оригинала для каждой картинки:

Sub AllPictSize()
       Dim PercentSize As Integer
       Dim oIshp As InlineShape
       Dim oshp As Shape
    
       PercentSize = InputBox("Ведите % от размера картинки", "Размеры картинки", 10)
    
       For Each oIshp In ActiveDocument.InlineShapes
           With oIshp
               .ScaleHeight = PercentSize
               .ScaleWidth = PercentSize
           End With
       Next oIshp
    
       For Each oshp In ActiveDocument.Shapes
           With oshp
               .ScaleHeight Factor:=(PercentSize / 100), _
                 RelativeToOriginalSize:=msoCTrue
               .ScaleWidth Factor:=(PercentSize / 100), _
                 RelativeToOriginalSize:=msoCTrue
           End With
       Next oshp
   End Sub

Нажать Alt + F8, выбрать макрос AllPictSize и нажать кнопку Выполнить.

Ничего не случится, если эти макросы сохранить все вместе, один за другим. Просто при запуске Alt + F8 выбирайте и выполняйте желаемый.

Post Views: 52
Прокрутить вверх