I'm looking to create an If Then Else, and having searched for an answer to this, I can't work out where I'm going wrong. I have added Tags to slides and have code that looks through each slide and gives a message box if the Tag is found. The IF function works, however having added 'ELSE', the code is just returning the ELSE, even though Tag can be found.
If anyone can tell me where I'm going wrong it would be really appreciated
Sub IfThenElse()
Dim oSld As Slide
For Each oSld In ActivePresentation.Slides
If oSld.Tags("MYTAGNAME") = "341377444" Then
MsgBox "Ref found"
Else: MsgBox "not found"
Exit For
End If
Next oSld
End Sub
If you want the loop to end after the first found tag or after the first slide w/o a tag, you'd need to mod this further. If you just want to get a msgbox for each slide where the tag is found, then this:
Sub IfThenElse()
Dim oSld As Slide
For Each oSld In ActivePresentation.Slides
If oSld.Tags("MYTAGNAME") = "341377444" Then
MsgBox "Ref found"
Else
MsgBox "not found"
End If
Next oSld
End Sub
Related
I try to use a selected picture on the slide and copy/paste it into the Placeholder (I can not load the picture from a file, it has to be from the slide itself.)
It works fine when I go through the code with F8 step by step. But when I run the macro, the placeholder stays empty.
I tried to set Delays in order to give PPT enough time but no matter how high I make the delay, it won't work (Placeholder doesn't get filled)
Any ideas, what could cause this weird behavior? Better ideas how to place the selected image into the template Placeholder (should work on Mac too though). Thank you for your time!
Sub SetImageIntoPlaceholder()
Dim sImage As Shape
Dim iSl As Integer
Dim oSl As Slide
Dim oPl As Shape
On Error GoTo ErrorHandler
If ActiveWindow.Selection.ShapeRange().Count <> 1 Then
MsgBox "Please select only the picture you wish to place in the Placeholder", vbOKOnly Or vbCritical, Application.Name
Exit Sub
End If
iSl = ActiveWindow.View.Slide.SlideIndex
Set oSl = ActivePresentation.Slides(iSl)
Set sImage = ActiveWindow.Selection.ShapeRange(1)
sImage.Copy
For Each oPl In oSl.Shapes
If oPl.Type = msoPlaceholder Then
With oPl
Select Case oPl.PlaceholderFormat.Type
Case Is = 18
'Its a picture placeholder
Delay 4
oPl.Select
Delay 4
ActiveWindow.View.Paste
Delay 5
'oSl.Shapes.Paste
Application.CommandBars.ExecuteMso ("SlideReset")
'Delay 1.5
'sImage.Delete
Exit Sub
Case Else
' ignore other shape types
End Select
End With
End If
Next oPl
ErrorHandler:
'Resume Next
End Sub
Try adding DoEvents after you copy and after you paste. Also, try separating your copy and paste operations into separate procedures. VBA should wait until the operations are complete before entering and exiting a procedure. I haven't tested it, but maybe something like this . . .
Option Explicit
Sub SetImageIntoPlaceholder()
Dim sImage As Shape
Dim iSl As Integer
Dim oSl As Slide
On Error GoTo ErrorHandler
If ActiveWindow.Selection.ShapeRange().Count <> 1 Then
MsgBox "Please select only the picture you wish to place in the Placeholder", vbOKOnly Or vbCritical, Application.Name
Exit Sub
End If
iSl = ActiveWindow.View.Slide.SlideIndex
Set oSl = ActivePresentation.Slides(iSl)
Set sImage = ActiveWindow.Selection.ShapeRange(1)
sImage.Copy
DoEvents
PastePictureInSlide oSl
ErrorHandler:
'Resume Next
End Sub
Private Sub PastePictureInSlide(ByVal oSl As Slide)
Dim oPl As Shape
For Each oPl In oSl.Shapes
If oPl.Type = msoPlaceholder Then
With oPl
Select Case .PlaceholderFormat.Type
Case Is = 18
'Its a picture placeholder
.Select
ActiveWindow.View.Paste
'oSl.Shapes.Paste
Application.CommandBars.ExecuteMso ("SlideReset")
DoEvents
Exit Sub
Case Else
' ignore other shape types
End Select
End With
End If
Next oPl
End Sub
Is there a way to align the text from right to left (it's Arabic) on all slides in a PowerPoint Presentation with a macro ? (I'm using O365).
In a Microsoft example I found this :
Application.ActivePresentation.Slides(1).Shapes(2) _
.TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignLeft
But i think that this example aligns the paragraphs of form 2 on slide 1 of the active presentation to the left.
So i don't know how to do it with all the shapes/slides types.
The professional coders may improve it, but I think this one should help you. You just have to select all slides before you click it, if you want the entire presentation to be done in one move. I think it is better than any entire-presentation-solution, because it gives you the opportunity to choose.
Option Explicit
Sub AlignAllTextLeft()
Dim osld As Slide
Dim oshp As Shape
Dim notesshp As Shape
Dim i As Long
Dim j As Long
Dim x As Long
On Error GoTo ErMsg
If MsgBox("You are going to change the text alignment of all text on all selected slides to left" & vbCrLf & "Continue?", vbYesNo) <> vbYes Then Exit Sub
For Each osld In ActiveWindow.Selection.SlideRange
For Each oshp In osld.Shapes
If oshp.HasTextFrame Then
oshp.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignLeft
End If
If oshp.HasTable Then
For i = 1 To oshp.Table.Rows.Count
For j = 1 To oshp.Table.Columns.Count
oshp.Table.Rows.Item(i).Cells(j).Shape.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignLeft
Next j
Next i
End If
Next oshp
For Each notesshp In osld.NotesPage.Shapes
If notesshp.HasTextFrame Then
notesshp.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignLeft
End If
Next notesshp
Next osld
For Each osld In ActiveWindow.Selection.SlideRange
For Each oshp In osld.Shapes
With oshp
Select Case .Type
Case Is = msoGroup
For x = 1 To .GroupItems.Count
If .GroupItems(x).HasTextFrame Then
oshp.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignLeft
End If
Next x
End Select
End With
Next oshp
Next
Exit Sub
ErMsg:
MsgBox "Please do not place the cursor between two slides"
End Sub
In the master layout I defined the placeholders where the images are added, but I can't find a solution to scale to fit them. The reason for the image placeholders is that the pictures can be added for different layouts without adding the exact location properties (Left, Top, Width, Height)
My current code looks like this:
Sub InsertPictures
ActivePresentation.Slides(1).Shapes.AddPicture FileName:="U:\xyz\EAP.png", _LinkToFile:=msoTrue
ActivePresentation.Slides(1).Shapes.AddPicture FileName:="U:\xyz\DAP_01.png", LinkToFile:=msoTrue, _
End Sub
In the picture below you can see on the left side how the picture is added with a image placeholder and on the right side how it should be added, when its fitted.
I found a code which does the "crop to fit", but it only works when the slide is selected:
Sub cropFit()
Dim osld As Slide
Dim oshp As Shape
On Error Resume Next
Set osld = ActiveWindow.View.Slide
If Not osld Is Nothing Then
For Each oshp In osld.Shapes
If oshp.Type = msoPlaceholder Then
If oshp.PlaceholderFormat.Type = ppPlaceholderPicture Then
oshp.Select
CommandBars.ExecuteMso ("PictureFitCrop")
End If 'picture placeholder
End If 'placehoder
Next oshp
End If ' Slide selected
End Sub
How do I have to change the code that directly after adding the images with the code above (Sub Insert Pictures), the images are cropped to fit in the presentation mode?
Thanks for your help in advance!
What we need to do is get the Picture Placeholders, and assign pictures to those placeholders. You will put your file names in an array that can hold as many strings as placeholders ( I used 3 below because you say you have 3 picture placeholders). Then we will insert the pictures at those placeholders and crop them to fit. I borrowed concepts used here and here. So your code would be:
Sub InsertPictures()
Dim FileNames(1 To 3) As String, Shps As Shapes, i As Integer
Set Shps = ActivePresentation.Slides(1).Shapes
FileNames(1) = "U:\xyz\EAP.png"
FileNames(2) = "U:\xyz\DAP_01.png"
' Filenames(3) = "Blah Blah Blah"
i = 1
For Each Shp In Shps.Placeholders
' You only need to work on Picture place holders
If Shp.PlaceholderFormat.Type = ppPlaceholderPicture Then
With Shp
' Now add the Picture
Set s = Shps.AddPicture(FileNames(i), msoTrue, msoTrue, _
.Left, .Top, .Width, .Height)
' Insert DoEvents here specially for big files, or network files
' DoEvents halts macro momentarily until the
' system finishes what it's doing which is loading the picture file
DoEvents
s.Select
CommandBars.ExecuteMso ("PictureFitCrop")
i = i + 1
End With
End If
If (i > UBound(FileNames)) Then Exit For
If (FileNames(i) = "") Then Exit For
Next Shp
End Sub
Thank you guys for your help! I managed to solve this problem with the following code:
Sub CropToFit()
ActivePresentation.Slides(1).Shapes.AddPicture FileName:="U:\xyz\EAP.png", _LinkToFile:=msoTrue
ActivePresentation.Slides(1).Shapes.AddPicture FileName:="U:\xyz\DAP_01.png", LinkToFile:=msoTrue, _
ActivePresentation.SlideShowWindow.view.Exit
Do Events
Dim osld As Slide
Dim oshp As Shape
On Error Resume Next
Set osld = ActiveWindow.view.Slide
If Not osld Is Nothing Then
For Each oshp In osld.Shapes
If oshp.Type = msoPlaceholder Then
If oshp.PlaceholderFormat.Type = ppPlaceholderPicture Then
oshp.Select
CommandBars.ExecuteMso ("PictureFitCrop")
End If 'picture placeholder
End If 'placehoder
Next oshp
End If ' Slide selected
End Sub
I have a macros that is unfortunately skipping all grouped shapes in PowerPoint where the text requires to be normalized (hard returns swapped with spacemarks). Now, I wrote a 'prepping' script that should find all shapes with text and ungroup those. For some reason it is not working. This should be so simple, yet I cannot get it to work. Please help!
Sub Ungroupallshapes()
Dim osld As Slide
Dim oshp As Shape
For Each osld In ActivePresentation.Slides
For Each oshp In osld.Shapes
If oshp.Type = msoGroup Then
If oshp.HasTextFrame Then
If oshp.TextFrame.HasText Then oshp.Ungroup
End If
End If
Next oshp
Next osld
End Sub
Thank you!
I know this is an old post, but I needed a function to ungroup every group in a PowerPoint regardless of issues with animations as mentioned above. I used the following to continue looping through the slide objects while there was a group detected.Sub
Sub Shapes_UnGroup_All()
Dim sld As Slide
Dim shp As Shape
Dim intCount As Integer
intCount = 0
Dim groupsExist As Boolean: groupsExist = True
If MsgBox("Are you sure you want To ungroup every level of grouping On every slide?", (vbYesNo + vbQuestion), "Ungroup Everything?") = vbYes Then
For Each sld In ActivePresentation.Slides ' iterate slides
Debug.Print "slide " & sld.SlideNumber
Do While (groupsExist = True)
groupsExist = False
For Each shp In sld.Shapes
If shp.Type = msoGroup Then
shp.Ungroup
intCount = intCount + 1
groupsExist = True
End If
Next shp
Loop
groupsExist = True
Next sld
End If
MsgBox "All Done " & intCount & " groups are now ungrouped."
End Sub
Groups don't have TextFrames, so you're testing for something that will never happen.
If oshp.Type = msoGroup then oshp.Ungroup
should do it for simple groupings. But ungrouping can have unwanted side effects (blows away any animation on the group shape, for example). And it's not usually necessary. Consider:
Sub ChangeTheText()
Dim oshp As Shape
Dim oSld As Slide
Dim x As Long
For Each oSld In ActivePresentation.Slides
For Each oshp In oSld.Shapes
If oshp.HasTextFrame Then
oshp.TextFrame.TextRange.Text = "Ha! Found you!"
Else
If oshp.Type = msoGroup Then
For x = 1 To oshp.GroupItems.Count
If oshp.GroupItems(x).HasTextFrame Then
oshp.GroupItems(x).TextFrame.TextRange.Text _
= "And you too, you slippery little devil!"
End If
Next
End If
End If
Next
Next
End Sub
That still leaves you with the possible problem of groups within groups (within groups (within groups)) etc. There are ways around that, but if it ain't broke, we don't need to fix it.
I have to do a search and replace on certain colors in my PowerPoint slides. Long story and I'm not allowed to change the template color schemes.
I found this VBA script http://skp.mvps.org/pptxp006.htm and it works great on lines/fill in PPT graphics. But it doesn't seem to handle the text properly.
The general approach of this VBA script is:
For Each oSld In ActivePresentation.Slides
For Each oShp In oSld.Shapes
If oShp.Type = msoGroup Then
For I = 1 To oShp.GroupItems.Count
[[ do something to oShp.GroupItems(i) ]]
Next I
Else
[[ do something to oShp ]]
End If
Next oShp
Next oSld
and the "do something" includes a call to FindAndReColourText():
Function FindAndReColourText(oShp As Shape, _
oRGB As Long, oNewRGB As Long)
Dim I As Integer
Dim oTxtRng As TextRange
On Error Resume Next
If oShp.HasTextFrame Then
If oShp.TextFrame.HasText Then
Set oTxtRng = oShp.TextFrame.TextRange
For I = 1 To oTxtRng.Runs.Count
With oTxtRng.Runs(I).Font.Color
If .Type = msoColorTypeRGB Then
If .rgb = oRGB Then
.rgb = oNewRGB
End If
End If
End With
Next I
End If
End If
End Function
I've checked and it does seem to iterate through text but it's not matching the color somehow. Any suggestions on how I should debug?
(I don't really know where to look to find this out and someone dumped this task on me quickly with dozens of slides I need to change.)
Aha -- the problem was that it wasn't working for text that uses template colors; the .Type = msoColorTypeRGB test wasn't matching.
If .Type = msoColorTypeRGB Then
If .rgb = oRGB Then
.rgb = oNewRGB
End If
End If
I removed this outer If and it worked properly.