Discussion :

[coritani16]

Bonjour à vous,

J'utilise une macro qui cherche du texte et le remplace dans un fichier ppt : cela me permet de créer des documents ppt personnalisés rapidement.
Ces derniers jours, j'ai essayé de rajouter des tableaux dans mon ppt et j'ai découvert que ma sub ne va pas dans les cellules de mon tableau pour trouver et remplacer le texte.

En fait ma Sub va dans les slides, puis dans les shapes, puis dans les textframes et cherche le texte pour le remplacer si besoin.

Je souhaiterais que ma sub aille également dans les tableaux en plus des textframes mais je ne sais pas comment faire !
merci beaucoup par avance à ceux qui m'aideront !

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
Sub Switch(pptDoc As PowerPoint.Presentation, FindString As String, ReplaceString As Variant)
    With pptDoc
        For Each oSld In .Slides
            For Each oShp In oSld.Shapes
                If oShp.HasTextFrame Then
                    If oShp.TextFrame.HasText Then
                        Set oTxtRng = oShp.TextFrame.TextRange
                        Set oTxtFnd = oTxtRng.Find(FindWhat:=FindString)
 
                        Do While Not oTxtFnd Is Nothing
                        Set oTmpRng = oTxtRng.Replace(FindWhat:=FindString, Replacewhat:=ReplaceString, After:=0, MatchCase:=True, WholeWords:=False)
                        Set oTxtFnd = oTxtRng.Find(FindWhat:=FindString)
                        Loop
 
                Else:   Set oTmpRng = oTxtRng.Replace(FindWhat:=FindString, Replacewhat:=ReplaceString, After:=0, MatchCase:=True, WholeWords:=False)
                        Do While Not oTmpRng Is Nothing
                        Set oTmpRng = oTxtRng.Replace(FindWhat:=FindString, Replacewhat:=ReplaceString, After:=0, MatchCase:=True, WholeWords:=False)
                        Loop
 
                    End If
                End If
            Next oShp
        Next oSld
    End With
End Sub

[EricDgn]

Bonjour,

A tester, cette version plus complète:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
'--- https://stackoverflow.com/questions/18062066/how-to-modify-text-in-powerpoint-via-excel-vba-without-changing-style
 
Sub Replace_in_Shapes_and_Tables(pPPTFile As Presentation, sFromStr As String, sToStr As String)
    Dim sld         As Slide
    Dim shp         As Shape
    Dim i           As Long
    Dim j           As Long
    Dim m           As Long
    Dim trFoundText As TextRange
 
    For Each sld In pPPTFile.Slides
        For Each shp In sld.Shapes
 
            If shp.HasTextFrame Then
                If shp.TextFrame.HasText Then                   ' only perform action on shape if it contains the target string
                    Set trFoundText = shp.TextFrame.TextRange.Find(sFromStr)
                    If Not (trFoundText Is Nothing) Then
                        m = shp.TextFrame.TextRange.Find(sFromStr).Characters.Start
                        shp.TextFrame.TextRange.Characters(m).InsertBefore (sToStr)
                        shp.TextFrame.TextRange.Find(sFromStr).Delete
                    End If
                End If
            End If
 
            If shp.HasTable Then
                For i = 1 To shp.Table.Rows.Count
                    For j = 1 To shp.Table.Columns.Count
 
                        Set trFoundText = shp.Table.Rows.Item(i).Cells(j).Shape.TextFrame.TextRange.Find(sFromStr)
                        If Not (trFoundText Is Nothing) Then
                            m = shp.Table.Rows.Item(i).Cells(j).Shape.TextFrame.TextRange.Find(sFromStr).Characters.Start
                            shp.Table.Rows.Item(i).Cells(j).Shape.TextFrame.TextRange.Characters(m).InsertBefore (sToStr)
                            shp.Table.Rows.Item(i).Cells(j).Shape.TextFrame.TextRange.Find(sFromStr).Delete
                        End If
 
                    Next j
                Next i
            End If
 
        Next shp
    Next sld
 
    For Each shp In pPPTFile.SlideMaster.Shapes
        If shp.HasTextFrame Then
            If shp.TextFrame.HasText Then
                Set trFoundText = shp.TextFrame.TextRange.Find(sFromStr)
                If Not (trFoundText Is Nothing) Then
                    m = shp.TextFrame.TextRange.Find(sFromStr).Characters.Start
                    shp.TextFrame.TextRange.Characters(m).InsertBefore (sToStr)
                    shp.TextFrame.TextRange.Find(sFromStr).Delete
                End If
 
            End If
        End If
 
        If shp.HasTable Then
            For i = 1 To shp.Table.Rows.Count
                For j = 1 To shp.Table.Columns.Count
                    Set trFoundText = shp.Table.Rows.Item(i).Cells(j).Shape.TextFrame.TextRange.Find(sFromStr)
                    If Not (trFoundText Is Nothing) Then
                        m = shp.Table.Rows.Item(i).Cells(j).Shape.TextFrame.TextRange.Find(sFromStr).Characters.Start
                        shp.Table.Rows.Item(i).Cells(j).Shape.TextFrame.TextRange.Characters(m).InsertBefore (sToStr)
                        shp.Table.Rows.Item(i).Cells(j).Shape.TextFrame.TextRange.Find(sFromStr).Delete
                    End If
 
                Next j
            Next i
        End If
    Next shp
 
End Sub

Cordialement.