[Iska]

В общем, что я вижу.

1. В результате произведённого изменения пропорций произошло не «растягивание»:

При изменении размеров слайдов с 4:3, на 16:9 в PowerPoint 2007 изображения растягиваются причем только по ширине слайдов презентации. »

изображений, а сжатие по высоте. Поэтому «растягивание» приведёт только к тому, что рисунки и объекты «уползут» за размеры слайда.

2. Ваш алгоритм работоспособен только при условии, что изображения, помещённые в презентацию изменялись строго пропорционально. Если же изображение до конвертации с 4:3 в 16:9 уже имело иные пропорции, нежели 1x1, что отнюдь не редкость — то весь алгоритм летит к чёрту.

Так что, я бы сделал иначе. Пробуйте:

Скрытый текст

Код:

Option Explicit

Sub ReScaleToHeight()
    Dim objSlide As Slide
    Dim objShape As Shape
    
    Dim intCurrentWidth As Integer
    Dim intCurrentHeigth As Integer
    
    Dim intOriginalWidth As Integer
    Dim intOriginalHeigth As Integer
    
    Dim sngAspectRatio As Single


    For Each objSlide In ActivePresentation.Slides
        For Each objShape In objSlide.Shapes
            With objShape
                If .Type = msoPicture Or .Type = msoEmbeddedOLEObject Then
                    intCurrentWidth = .Width
                    intCurrentHeigth = .Height
                    
                    .ScaleHeight CSng(1), msoTrue
                    .ScaleWidth CSng(1), msoTrue
                    
                    intOriginalWidth = .Width
                    intOriginalHeigth = .Height
                    
                    If intCurrentWidth / intOriginalWidth < intCurrentHeigth / intOriginalHeigth Then
                        sngAspectRatio = intCurrentWidth / intOriginalWidth
                    Else
                        sngAspectRatio = intCurrentHeigth / intOriginalHeigth
                    End If
                    
                    .ScaleHeight sngAspectRatio, msoTrue
                    .ScaleWidth sngAspectRatio, msoTrue
                End If
            End With
        Next
    Next
End Sub

Если всё же хотите по-своему — поменяйте в условии < на >.