.
.
Sub XXL()
Dim ppt As Object
Dim pres As PowerPoint.Presentation
Dim sld As PowerPoint.Slide
Dim ppE As PowerPoint.Effect
Dim shp As PowerPoint.Shape
Dim arr() As Variant, vrtItem As Variant
Dim dlg As FileDialog
Dim pad As String, tmp As String, i As Integer
Set dlg = Application.FileDialog(msoFileDialogFolderPicker)
With dlg
.AllowMultiSelect = False
If .Show = True Then pad = .SelectedItems(1)
End With
tmp = Dir(pad & "\*.ppt", vbNormal)
Do While Not tmp = ""
ReDim Preserve arr(i)
arr(i) = pad & "\" & tmp
i = i + 1
tmp = Dir
Loop
Set ppt = New PowerPoint.Application
For i = LBound(arr) To UBound(arr)
Set pres = ppt.Presentations.Open(arr(i), msoFalse)
For Each sld In pres.Slides.Range
For Each shp In sld.Shapes
With shp
If (.Type = msoPicture) Or (.Type = msoAutoShape And Not .HasTextFrame) Then
.LockAspectRatio = msoTrue
.Top = 50
.Width = 710
.Left = 5
.Fill.Solid
.Fill.Visible = msoFalse
End If
End With
Next
Next
pres.Saved = msoTrue
pres.Close
Next i
End Sub
)Option Explicit
Public Sub PositionImages()
Dim lngPresentations As Long
Dim strPresentationPath As String
Dim objShape As Object
Dim objSlide As Object
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = True
.Show
For lngPresentations = 1 To .SelectedItems.Count
strPresentationPath = .SelectedItems(lngPresentations)
With CreateObject("PowerPoint.Application")
.Presentations.Open strPresentationPath
With .ActivePresentation
For Each objSlide In .Slides
For Each objShape In objSlide.Shapes
With objShape
If .Type = msoPicture Then
.LockAspectRatio = msoTrue
.Left = 0
.Top = 2.1 / 25.4 * 72 * 10
.Width = 25.4 / 25.4 * 72 * 10
End If
End With
Next
Next
.Save
.Close
End With
End With
Next
End With
MsgBox "Images positioned in all presentations."
End Sub