Pb Macro dans powerpoint

Bonjour à tous et merci d'avance pour votre aide.

Je suis en train de créer un jeu avec powerpoint et j'ai besoin de remplacer les questions et les réponses.

Les questions et les réponses seront à changer toutes semaines.

Pour simplifier le remplacement, je veux utiliser une macro trouvé sur le net qui marche très bien.

Par contre, dès qu'il y a une zone texte avec une image, la macro se plante à la ligne :

Set oTxtRng = oShp.TextFrame.TextRange


Avez vous un avis sur le pb?

Voici la première partie de la macro qui devrait remplacer plus de 75 zones de textes une fois que le pb sera résolu.


Merci d'avance pour votre aide



Sub ReplaceText()


Dim LastSlide, NumSlide As Integer

LastSlide = Application.ActivePresentation.Slides.Count

Dim oSld As Slide
Dim oShp As Shape
Dim oTxtRng As TextRange
Dim oTmpRng As TextRange
Dim strWhatReplace As String, strReplaceText As String

' texte à trouver
strWhatReplace = "Question 01?"
' à remplacer par
strReplaceText = "Question 01????"



' A faire sur toutes les diapos
For NumSlide = 1 To LastSlide
'For Each oSld In ActivePresentation.Slides
' go during each shapes and textRanges
For Each oShp In ActivePresentation.Slides(NumSlide).Shapes
' replace in TextFrame
Set oTxtRng = oShp.TextFrame.TextRange
Set oTmpRng = oTxtRng.Replace(FindWhat:=strWhatReplace, Replacewhat:=strReplaceText, WholeWords:=False)

Do While Not oTmpRng Is Nothing

Set oTxtRng = oTxtRng.Characters _
(oTmpRng.Start + oTmpRng.Length, oTxtRng.Length)
Set oTmpRng = oTxtRng.Replace(FindWhat:=strWhatReplace, Replacewhat:=strReplaceText, WholeWords:=False)
Loop
Next oShp
Next NumSlide

'*********************
' texte à trouver
strWhatReplace = "Q01 Réponse A"

' à remplacer par
strReplaceText = "Q01 Réponse AAA"




' A faire sur toutes les diapos
For NumSlide = 1 To LastSlide
'For Each oSld In ActivePresentation.Slides
' go during each shapes and textRanges
For Each oShp In ActivePresentation.Slides(NumSlide).Shapes
' replace in TextFrame
Set oTxtRng = oShp.TextFrame.TextRange
Set oTmpRng = oTxtRng.Replace(FindWhat:=strWhatReplace, Replacewhat:=strReplaceText, WholeWords:=False)

Do While Not oTmpRng Is Nothing

Set oTxtRng = oTxtRng.Characters _
(oTmpRng.Start + oTmpRng.Length, oTxtRng.Length)
Set oTmpRng = oTxtRng.Replace(FindWhat:=strWhatReplace, Replacewhat:=strReplaceText, WholeWords:=False)
Loop
Next oShp
Next NumSlide



'*********************
' texte à trouver
strWhatReplace = "Q01 Réponse B"

' à remplacer par
strReplaceText = "Q01 Réponse BBB"




' A faire sur toutes les diapos
For NumSlide = 1 To LastSlide
'For Each oSld In ActivePresentation.Slides
' go during each shapes and textRanges
For Each oShp In ActivePresentation.Slides(NumSlide).Shapes
' replace in TextFrame
Set oTxtRng = oShp.TextFrame.TextRange
Set oTmpRng = oTxtRng.Replace(FindWhat:=strWhatReplace, Replacewhat:=strReplaceText, WholeWords:=False)

Do While Not oTmpRng Is Nothing

Set oTxtRng = oTxtRng.Characters _
(oTmpRng.Start + oTmpRng.Length, oTxtRng.Length)
Set oTmpRng = oTxtRng.Replace(FindWhat:=strWhatReplace, Replacewhat:=strReplaceText, WholeWords:=False)
Loop
Next oShp
Next NumSlide



'*********************
' texte à trouver
strWhatReplace = "Q01 Réponse C"

' à remplacer par
strReplaceText = "Q01 Réponse CCC"




' A faire sur toutes les diapos
For NumSlide = 1 To LastSlide
'For Each oSld In ActivePresentation.Slides
' go during each shapes and textRanges
For Each oShp In ActivePresentation.Slides(NumSlide).Shapes
' replace in TextFrame
Set oTxtRng = oShp.TextFrame.TextRange
Set oTmpRng = oTxtRng.Replace(FindWhat:=strWhatReplace, Replacewhat:=strReplaceText, WholeWords:=False)

Do While Not oTmpRng Is Nothing

Set oTxtRng = oTxtRng.Characters _
(oTmpRng.Start + oTmpRng.Length, oTxtRng.Length)
Set oTmpRng = oTxtRng.Replace(FindWhat:=strWhatReplace, Replacewhat:=strReplaceText, WholeWords:=False)
Loop
Next oShp
Next NumSlide





End Sub