Need VBA Code to find a picture which was not have a same scale of height and width of percentage in entire PowerPoint Presentation

Hi,

pls try

Sub macro()
Dim Shp As Shape
For Each sld In ActivePresentation.Slides
    For Each Shp In sld.Shapes
        If Shp.Type = msoPicture Then
            isSclDiff = False
            If ImageScale(Shp, True) <> ImageScale(Shp, False) Then
                Shp.Line.ForeColor.RGB = vbRed
                Shp.Line.Weight = 2.5
                Shp.Line.Visible = True
                isSclDiff = True
                Idx = Idx + 1
           End If
        End If
    Next
    strRpt = strRpt & IIf(isSclDiff, ("Slide " & sld.SlideIndex & vbCrLf), "")
Next
If Idx > 0 Then
    MsgBox Idx & " image(s) not scaled the same" & vbCrLf & strRpt
Else
    MsgBox "No differences"
End If
End Sub
Function ImageScale(Shp As Shape, IsHeight) As Single 'isHeight = False Calculate Width
    Dim ShpW As Single, ShpH As Single
    Dim isLocked As Boolean
    ShpH = Shp.Height
    ShpW = Shp.Width
    
    If Shp.LockAspectRatio Then isLocked = True
    Shp.LockAspectRatio = msoFalse
    Shp.ScaleHeight 1, msoTrue
    Shp.ScaleWidth 1, msoTrue
    ResH = ShpH / Shp.Height
    ResW = ShpW / Shp.Width
    ImageScale = IIf(IsHeight, ResH, ResW)
    Shp.ScaleHeight ResH, msoTrue
    Shp.ScaleWidth ResW, msoTrue
    If isLocked Then Shp.LockAspectRatio = msoTrue
End Function

Select allOpen in new window

Regards

Hi Rgonzo1971,

Thank you for came with this code, but still we need some correction in this code

1. It was found a picture which have not a 100% scale. Its may be the scale (80%*80%), (42%*42%) all are equal scale, so this picture no need to highlight. if it is scale (40%*80%), (20%*21%) then only its need to be highlight because this are not equal scale of height and width. For better understanding see my below screenshot below.

2. The Count of the images is working, but the "slide no" shows all the "slide no" form the "picture got" to end of the slide. (eg: i have a picture only in  slide 2... this shows slide 2, slide 3, slide 4, slide 5, till the end)

3. This was not working, if two or three pictures are in group...


Regards
Arunraj Sekar

could you send a dummy?

then try

Sub macro()
Dim Shp As Shape
Dim gShp As Shape
For Each sld In ActivePresentation.Slides
    For Each Shp In sld.Shapes
        isSclDiff = False
        If Shp.Type = msoPicture Then

            If ImageScale(Shp, True) <> ImageScale(Shp, False) Then
                Shp.Line.ForeColor.RGB = vbRed
                Shp.Line.Weight = 2.5
                Shp.Line.Visible = True
                isSclDiff = True
                Idx = Idx + 1
           End If
        ElseIf Shp.Type = msoGroup Then
            For Each gShp In Shp.GroupItems
                If gShp.Type = msoPicture Then
                    If Round(ImageScale(gShp, True), 5) <> Round(ImageScale(gShp, False), 5) Then
                        gShp.Line.Weight = 2.5
                        gShp.Line.Visible = True
                        gShp.Line.ForeColor.RGB = vbRed
                        isSclDiff = True
                        Idx = Idx + 1
                    End If
                End If
            Next
        End If
    Next
    strRpt = strRpt & IIf(isSclDiff, ("Slide " & sld.SlideIndex & vbCrLf), "")
Next
If Idx > 0 Then
    MsgBox Idx & " image(s) not scaled the same" & vbCrLf & strRpt
Else
    MsgBox "No differences"
End If
End Sub
Function ImageScale(Shp As Shape, IsHeight) As Single 'isHeight = False Calculate Width
    Dim ShpW As Single, ShpH As Single
    Dim isLocked As Boolean
    ShpH = Shp.Height
    ShpW = Shp.Width
    
    If Shp.LockAspectRatio Then isLocked = True
    Shp.LockAspectRatio = msoFalse
    Shp.ScaleHeight 1, msoTrue
    Shp.ScaleWidth 1, msoTrue
    ResH = ShpH / Shp.Height
    ResW = ShpW / Shp.Width
    ImageScale = Round(IIf(IsHeight, ResH, ResW), 6)
    Shp.ScaleHeight ResH, msoTrue
    Shp.ScaleWidth ResW, msoTrue
    If isLocked Then Shp.LockAspectRatio = msoTrue
End Function

Select allOpen in new window

You might want to also check for a picture contained in a placeholder.
Something like this:

Sub chex()
   Dim oshp As Shape
   Dim osld As Slide
   For Each osld In ActivePresentation.Slides
      For Each oshp In osld.Shapes
         If isPic(oshp) Then
            If getScaleH(oshp, osld) <> getScaleW(oshp, osld) Then
               oshp.Line.Visible = True
               oshp.Line.ForeColor.RGB = vbRed
               oshp.Line.Weight = 4
               oshp.Tags.Add "NOT", "EQUAL"
            End If
         End If
      Next oshp
   Next osld
End Sub

Function getScaleW(oshp As Shape, osld As Slide)
   Dim oshp2 As Shape
   Dim oshpW As Single
   Dim oshpH As Single
   oshp.Copy
   osld.Shapes.Paste
   Set oshp2 = osld.Shapes(osld.Shapes.Count)
   oshpW = oshp.Width
   oshpH = oshp.Height
   oshp2.ScaleWidth (1), True
   getScaleW = oshp.Width / oshp2.Width
   oshp2.Delete
End Function

Function getScaleH(oshp As Shape, osld As Slide)
   Dim oshp2 As Shape
   Dim oshpH As Single
   oshp.Copy
   osld.Shapes.Paste
   Set oshp2 = osld.Shapes(osld.Shapes.Count)
   oshpH = oshp.Height
   oshp2.ScaleHeight (1), True
   getScaleH = oshp.Height / oshp2.Height
   oshp2.Delete
End Function

Function isPic(oshp As Shape)
   If oshp.Type = msoPicture Then
      isPic = True
      Exit Function
   End If
   If oshp.Type = msoPlaceholder Then
      If oshp.PlaceholderFormat.ContainedType = msoPicture Then
         isPic = True
         Exit Function
      End If
   End If
End Function

Select allOpen in new window

Hi Rgonzo1971 and JSRWilson,

Its working... but its shows the same scale also

Could you send a dummy?

There are rounding errors occurring when scaling a picture to what appears to be something equal in the UI but in fact, the result is not exactly equal. So I modified the code to deal with this, added support for groups and simplified the code to make it faster for larger decks.

Option Explicit

' Checks all pictures in all slides for aspect ratio 1:1 and highlights any that are not
Sub CheckPictureAspectRatio()
  Dim oShp As Shape
  Dim oSld As Slide
  Dim oGrpItem As Shape
  For Each oSld In ActivePresentation.Slides
    For Each oShp In oSld.Shapes
      If oShp.Type = msoGroup Then
        For Each oGrpItem In oShp.GroupItems
          If isPic(oGrpItem) Then CheckAndHighlightPicture oSld, oGrpItem
        Next
      End If
      If isPic(oShp) Then CheckAndHighlightPicture oSld, oShp
    Next oShp
  Next oSld
End Sub

Sub CheckAndHighlightPicture(oSld As Slide, oShp As Shape)
  If Not isScaleEqual(oSld, oShp) Then
     oShp.Line.Visible = True
     oShp.Line.ForeColor.RGB = vbRed
     oShp.Line.Weight = 4
     oShp.Tags.Add "NOT", "EQUAL"
  End If
End Sub

Function isScaleEqual(oSld As Slide, oShp As Shape) As Boolean
  Dim oShp2 As Shape
  Dim scaleW As Integer
  Dim scaleH As Integer
  oShp.Copy
  Set oShp2 = oSld.Shapes.Paste(1)
  oShp2.ScaleWidth (1), True
  scaleW = oShp.Width / oShp2.Width * 100
  oShp2.ScaleHeight (1), True
  scaleH = oShp.Height / oShp2.Height * 100
  If scaleW = scaleH Then isScaleEqual = True
  oShp2.Delete
End Function

Function isPic(oShp As Shape)
  If oShp.Type = msoPicture Then
    isPic = True
    Exit Function
  End If
  If oShp.Type = msoPlaceholder Then
    If oShp.PlaceholderFormat.ContainedType = msoPicture Then
      isPic = True
      Exit Function
    End If
  End If
End Function

Select allOpen in new window

ale Hi Jamie Garroch,

Its missed to highlight the picture if scale of height and width is not equal.... for more details see the above description and screenshot...

1. Need to highlight with red border (eg., 80%*79%, 40%*39%, 15%*14%) Note: scale of height*width is not equal
2. No Need to highlight (e.g 80%*80, 100%*100%, 70%*70% etc.


In this code what its done  
1. if check the scale of height and width is 100%*100%
2. else highlight with red color

In this what i excepted is
1. if check the scale of height and width is equal (Note: 70%*70% also equal)
2. else highlight with red color