Option Explicit
Sub PrintMaximizedImages()
'
' constants
Const kiZoomMax = 400
Const kiZoomMin = 10
'
' declarations
Dim iOrientation As Integer, sPrintArea As String, vZoom As Variant
Dim iFitToPagesWide As Integer, iFitToPagesTall As Integer
Dim shp As Shape
Dim I As Integer
'
' start
With ActiveSheet.PageSetup
iOrientation = .Orientation
sPrintArea = .PrintArea
vZoom = .Zoom
iFitToPagesWide = .FitToPagesWide
iFitToPagesTall = .FitToPagesTall
End With
'
' process
With ActiveSheet.PageSetup
For I = 1 To ActiveSheet.Shapes.Count
Set shp = ActiveSheet.Shapes(I)
If shp.Width <= shp.Height Then .Orientation = xlPortrait Else .Orientation = xlLandscape
.PrintArea = Range(shp.TopLeftCell.Address, shp.BottomRightCell.Address).Address
.Zoom = kiZoomMax
Do Until .Pages.Count = 1 Or .Zoom = kiZoomMin
.PrintArea = ""
.PrintArea = Range(shp.TopLeftCell.Address, shp.BottomRightCell.Address).Address
.Zoom = .Zoom - 1
Loop
If .Pages.Count > 1 Then
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
End If
ActiveSheet.PrintPreview True
Next I
End With
'
' end
With ActiveSheet.PageSetup
.Orientation = iOrientation
.PrintArea = sPrintArea
.Zoom = vZoom
.FitToPagesWide = iFitToPagesWide
.FitToPagesTall = iFitToPagesTall
End With
Set shp = Nothing
Beep
'
End Sub