Microsoft Office Forums - View Single Post - Macro to make image fit to slide exactly in PowerPoint

AllekieF · 10-13-2023, 03:21 AM

Modified the code a bit. Should work, but doesn't check for correct selection type.

Code:

Option Explicit

Sub reziseImage()
Dim pageHeight As Integer, pageWidth As Integer
Dim cropSize As Double

pageHeight = ActivePresentation.PageSetup.SlideHeight
pageWidth = ActivePresentation.PageSetup.SlideWidth

If ActiveWindow.Selection.Type = ppSelectionShapes Then
    Application.CommandBars.ExecuteMso ("PictureResetAndSize")
    With ActiveWindow.Selection.ShapeRange
        .LockAspectRatio = True
        If .Height / .Width > pageHeight / pageWidth Then
            cropSize = (pageWidth / .Width * .Height - pageHeight) / (pageWidth / .Width) / 2
            .Width = pageWidth
            .PictureFormat.CropTop = cropSize
            .PictureFormat.CropBottom = cropSize
        Else
            cropSize = (pageHeight / .Height * .Width - pageWidth) / (pageHeight / .Height) / 2
            .Height = pageHeight
            .PictureFormat.CropLeft = cropSize
            .PictureFormat.CropRight = cropSize
        End If
        .Left = 0
        .Top = 0
    End With
End If
End Sub