Изменение размера всех изображений в рабочей книге до фиксированной высоты в Excel VBA

Question

Я пытаюсь изменить размеры всех изображений в книге с сотнями листов (некоторые из которых содержат встроенные jpgs / pngs или диаграммы, некоторые нет). Я хочу, чтобы все диаграммы и рисунки имели одинаковую ширину и НЕ имели разрыва страницы в середине рисунка, но не знаю, как это сделать. Вот мой код, который, похоже, не работает ...

'Resize all the pictures to fit the page while maintaining aspect ratio
With Application
    .ScreenUpdating = False
    Dim pict As Shape

    On Error Resume Next

    For Each WS In Worksheets
        For Each pict In WS.Shapes
            If pict.Type = msoPicture Or pict.Type = msoGraphic Or pict.Type =     msoIgxGraphic And pict.Width > 1 And pict.Height > 1 Then
                WS.Activate
                pict.ShapeRange.LockAspectRatio = msoTrue
                pict.ShapeRange.Height = 250

                n = n + 1
            End If
        Next pict
    Next WS

    MsgBox n & " pictures were resized to fit the page successfully."
    .ScreenUpdating = True
End With

Answer 1

Сначала установите вид страницы.

ActiveWindow.View = xlPageBreakPreview

Во-вторых, вам нужно иметь данные в любой ячейке, чтобы делать разрывы страниц.

.Range("a10000") = "d"

Затем поместите картинку в ячейку разрыва страницы.

Sub test()
'Resize all the pictures to fit the page while maintaining aspect ratio
Dim Ws As Worksheet

ActiveWindow.View = xlPageBreakPreview
With Application
    .ScreenUpdating = False
    Dim pict As Shape
    Dim rngT As Range
    'On Error Resume Next

    For Each Ws In Worksheets
        Ws.Range("a10000") = "d"
        n = 0
        For Each pict In Ws.Shapes
            If pict.Type = msoPicture Or pict.Type = msoGraphic Or pict.Type = msoIgxGraphic And pict.Width > 1 And pict.Height > 1 Then
                Ws.Activate
                pict.LockAspectRatio = msoTrue
                If n = 0 Then
                    Set rngT = Ws.Range("a1")
                Else
                    Set rngT = Ws.HPageBreaks(n).Location
                End If
                With pict
                    .Top = rngT.Top
                    .Left = rngT.Left
                    .Height = 250
                End With
                n = n + 1
            End If
        Next pict
        Ws.Range("a10000") = Empty
    Next Ws

    MsgBox n & " pictures were resized to fit the page successfully."
    .ScreenUpdating = True
End With
End Sub

Answer 2

Удалить ShapeRange из

pict.LockAspectRatio = msoTrue
pict.Height = 250

Я не уверен, как это работает с сгруппированными объектами, но по крайней мере вы что-то получаете.