Pictures in My PowerPoint Photo Album Will Not Rotate

For some strange reason if you create a photo album and include CAPTIONS MSFT lock several features in the XML code.

This includes UNGROUP and ROTATE which makes no sense to us. The ability to move and resize the image itself WITHING the group is also locked. This makes more sense.

The code below tries to unlock all of these features. Make sure you run on a COPY and only on Photo Albums. If you understand XML you can also open the XML and change the attributes. This is not covered here though.

Sub fixAlbum()
Dim osld As Slide
Dim oshp As Shape
Dim pasteshp As Shape
Dim sngL As Single
Dim sngT As Single
Dim x As Integer
Dim i As Integer
Dim strname As String
On Error Resume Next
For Each osld In ActivePresentation.Slides
For i = osld.Shapes.Count To 1 Step -1
Set oshp = osld.Shapes(i)
If oshp.Type = msoGroup Then
Err.Clear
' try and rotate
oshp.Rotation = oshp.Rotation + 1
If Err = 0 Then
oshp.Rotation = oshp.Rotation - 1
Else
' it errored - rotation locked
x = x + 1
sngL = oshp.GroupItems(1).Left
sngT = oshp.GroupItems(1).Top
strname = oshp.GroupItems(2).Name
oshp.GroupItems(1).Cut
Set pasteshp = osld.Shapes.PasteSpecial(ppPasteJPG)(1)
With pasteshp
.Left = sngL
.Top = sngT
.Name = "Picture " & CStr(x)
End With
osld.Shapes.Range(Array("Picture " & CStr(x), strname)).Group
End If
End If
Next i
x = 0
Next osld
End Sub

This code is to make pics in normal albums groupable

Sub fixAlbum2()
Dim osld As Slide
Dim oshp As Shape
Dim pasteshp As Shape
Dim sngL As Single
Dim sngT As Single
Dim x As Integer
Dim i As Integer
Dim strname As String
On Error Resume Next
For Each osld In ActivePresentation.Slides
For i = osld.Shapes.Count To 1 Step -1
Set oshp = osld.Shapes(i)
If oshp.Type = 13 Then
sngL = oshp.Left
sngT = oshp.Top
oshp.Cut
Set pasteshp = osld.Shapes.PasteSpecial(ppPasteJPG)(1)
With pasteshp
.Left = sngL
.Top = sngT
.Name = "Picture " & CStr(x)
End With
osld.Shapes.Range(Array("Picture " & CStr(x), strname)).Group
End If
Next i
Next osld
End Sub