Ponctuation automatique - Besoin d'optimisation

**Madlax** · 26/01/2016, 13h08

Bonjour,

Je souhaite mettre en oeuvre une macro de contrôle de la ponctuation dans mes rapports PPT.

J'ai d'abord conçu une macro qui permet de scanner l'ensemble du document et de remplacer toutes les occurrences d'un String (par exemple le fameux double espace) par un autre (l'espace seul

).

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
 Sub ReplaceAllSlidesAndTables(ToBeReplaced As String, Replaceby As String)
    Dim sld As Slide
    Dim grpItem As Shape
    Dim shp As Shape
    Dim i As Long
    Dim j As Long
 
    For Each sld In ActivePresentation.Slides
    For Each shp In sld.Shapes
        If shp.HasTextFrame Then
            If shp.TextFrame.HasText Then
                shp.TextFrame.TextRange.Text = Replace(shp.TextFrame.TextRange.Text, ToBeReplaced, Replaceby)
            End If
        End If
 
        If shp.HasTable Then
            For i = 1 To shp.Table.Rows.Count
                For j = 1 To shp.Table.Columns.Count
                shp.Table.Rows.Item(i).Cells(j).Shape.TextFrame.TextRange.Text = _
                    Replace(shp.Table.Rows.Item(i).Cells(j).Shape.TextFrame.TextRange.Text, ToBeReplaced, Replaceby)
                Next j
            Next i
        End If
 
    Next shp
Next
End Sub

Cette macro marche (enfin je crois

) mais je voudrais pouvoir la faire boucler tant qu'il y a des doubles espaces dans mon document (oui je vise directement les personnes qui mettent 20 espaces pour pouvoir retourner à la ligne...).

Seulement, je ne sais pas faire "tant qu'il y a des doubles espaces dans le doc". Je voulais mettre un count dans ma macro qui s'incrémente à chaque changement et la lancer tant que le count ne revient pas à vide. Mais je ne sais pas comment savoir quand il fait un changement...
Ou je voulais avoir une macro qui me comptait le nombre de double espace dans le document avant de lancer celle de remplacement et boucler sur la macro qui compte. Mais je ne sais pas non plus compter un mot avec la fonction "find"...

Est-ce que quelqu'un aurait déjà bossé le sujet ? Ou aurait une solution à mettre en place autre pour arriver à mes fins?

Merci pour votre aide!

Madlax

**Madlax** · 26/01/2016, 17h33

Re-bonjour à tous!

Grâce aux propositions de discussion en bas de mon post j'ai réussi à créer une solution quasi satisfaisante!
Post dont je me suis inspiré : Méthode Find dans un nom d'objet

Il me reste néanmoins des shapes que je n'atteins pas avec ce code : les shapes groupées!!

Est-ce que quelqu'un saurait comment boucler à l'intérieur des groupes svp?

Merci beaucoup pour votre aide

Ci-dessous mon code pour voir où j'en suis :

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
Sub ReplaceAllSlidesAndTables(ToBeReplaced As String, Replaceby As String)
 
Dim sld As Slide
Dim grpItem As Shape
Dim shp As Shape
Dim i As Long
Dim j As Long
Dim NbRemp As Long
Dim iCar As Long
Dim NbCarToBeReplaced As Long
Dim myPos As Long
Dim foundText As Variant
Dim txt_r As String
 
NbRemp = 0
iCar = 1
 
For Each sld In ActivePresentation.Slides
    For Each shp In sld.Shapes
        If shp.HasTextFrame Then
            txt_r = shp.TextFrame.TextRange.Text
            Set foundText = shp.TextFrame.TextRange.Find(FindWhat:=ToBeReplaced, WholeWords:=msoFalse)
            Do While Not (foundText Is Nothing)
                NbCar = shp.TextFrame.TextRange.Characters.Count
                NbCarToBeReplaced = Len(ToBeReplaced)
                Do While iCar <= NbCar
                    myPos = InStr(iCar, txt_r, ToBeReplaced)
                    If myPos > 0 Then
                        iCar = myPos + NbCarToBeReplaced + 1
                        NbRemp = NbRemp + 1
                    Else: Exit Do
                    End If
                Loop
                Set foundText = shp.TextFrame.TextRange.Replace(FindWhat:=ToBeReplaced, replacewhat:=Replaceby, WholeWords:=msoFalse)
                ' passer au suivant
                Set foundText = shp.TextFrame.TextRange.Find(FindWhat:=ToBeReplaced, WholeWords:=msoFalse)
            Loop
        End If
 
        If shp.HasTable Then
            For i = 1 To shp.Table.Rows.Count
                For j = 1 To shp.Table.Columns.Count
                    txt_r = shp.Table.Rows.Item(i).Cells(j).Shape.TextFrame.TextRange.Text
                    Set foundText = shp.Table.Rows.Item(i).Cells(j).Shape.TextFrame.TextRange.Find(FindWhat:=ToBeReplaced, WholeWords:=msoFalse)
                    Do While Not (foundText Is Nothing)
                        NbCar = shp.Table.Rows.Item(i).Cells(j).Shape.TextFrame.TextRange.Characters.Count
                        NbCarToBeReplaced = Len(ToBeReplaced)
                        Do While iCar <= NbCar
                            myPos = InStr(iCar, txt_r, ToBeReplaced)
                            If myPos > 0 Then
                                iCar = myPos + NbCarToBeReplaced + 1
                                NbRemp = NbRemp + 1
                            Else: Exit Do
                            End If
                        Loop
                        Set foundText = shp.Table.Rows.Item(i).Cells(j).Shape.TextFrame.TextRange.Replace(FindWhat:=ToBeReplaced, replacewhat:=Replaceby, WholeWords:=msoFalse)
                        ' passer au suivant
                        Set foundText = shp.Table.Rows.Item(i).Cells(j).Shape.TextFrame.TextRange.Find(FindWhat:=ToBeReplaced, WholeWords:=msoFalse)
                    Loop
                Next j
            Next i
        End If
    Next shp
Next sld
MsgBox NbRemp & " remplacements"
End Sub

Madlax

**Madlax** · 29/01/2016, 10h44

Bonjour à tous,

Je continue à poster, si ça peut aider quelqu'un d'autre.

J'ai réussi à finaliser deux macros complémentaires qui me permettent
1. de changer les doubles espaces en espaces simples
2. de changer un string par un autre

Maintenant, il me reste 2 soucis majeurs qui ne me permettent pas d'utiliser ce développement :
1. ces macros sont tellement longues qu'il m'est impossible de les utiliser sur un rapport...
2. quand pour le remplacement des virgules, il me rajoute un espace après la virgule même dans les nombres. Il faudrait que la macro soit capable de détecter si la virgule est dans du texte ou un séparateur de décimale dans les nombres...

Si vous pouvez m'aider sur ces points ça serait génial!

Merci

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
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
Sub ReplaceSpace(ToBeReplaced As String, Replaceby As String)
 
Dim sld As Slide
Dim grpItem As Shape
Dim shp As Shape
Dim i As Long
Dim j As Long
Dim NbRemp As Long
Dim iCar As Long
Dim NbCarToBeReplaced As Long
Dim myPos As Long
Dim foundText As Variant
Dim txt_r As String
 
NbRemp = 0
iCar = 1
 
For Each sld In ActivePresentation.Slides
    For Each shp In sld.Shapes
        If shp.HasTextFrame Then
            txt_r = shp.TextFrame.TextRange.Text
            Set foundText = shp.TextFrame.TextRange.Find(FindWhat:=ToBeReplaced, WholeWords:=msoFalse)
            Do While Not (foundText Is Nothing)
                NbCar = shp.TextFrame.TextRange.Characters.Count
                NbCarToBeReplaced = Len(ToBeReplaced)
                Do While iCar <= NbCar
                    myPos = InStr(iCar, txt_r, ToBeReplaced)
                    If myPos > 0 Then
                        iCar = myPos + NbCarToBeReplaced + 1
                        NbRemp = NbRemp + 1
                    Else: Exit Do
                    End If
                Loop
                Set foundText = shp.TextFrame.TextRange.Replace(FindWhat:=ToBeReplaced, replacewhat:=Replaceby, WholeWords:=msoFalse)
                ' passer au suivant
                Set foundText = shp.TextFrame.TextRange.Find(FindWhat:=ToBeReplaced, WholeWords:=msoFalse)
            Loop
        End If
 
        If shp.HasTable Then
            For i = 1 To shp.Table.Rows.Count
                For j = 1 To shp.Table.Columns.Count
                    txt_r = shp.Table.Rows.Item(i).Cells(j).Shape.TextFrame.TextRange.Text
                    Set foundText = shp.Table.Rows.Item(i).Cells(j).Shape.TextFrame.TextRange.Find(FindWhat:=ToBeReplaced, WholeWords:=msoFalse)
                    Do While Not (foundText Is Nothing)
                        NbCar = shp.Table.Rows.Item(i).Cells(j).Shape.TextFrame.TextRange.Characters.Count
                        NbCarToBeReplaced = Len(ToBeReplaced)
                        Do While iCar <= NbCar
                            myPos = InStr(iCar, txt_r, ToBeReplaced)
                            If myPos > 0 Then
                                iCar = myPos + NbCarToBeReplaced + 1
                                NbRemp = NbRemp + 1
                            Else: Exit Do
                            End If
                        Loop
                        Set foundText = shp.Table.Rows.Item(i).Cells(j).Shape.TextFrame.TextRange.Replace(FindWhat:=ToBeReplaced, replacewhat:=Replaceby, WholeWords:=msoFalse)
                        ' passer au suivant
                        Set foundText = shp.Table.Rows.Item(i).Cells(j).Shape.TextFrame.TextRange.Find(FindWhat:=ToBeReplaced, WholeWords:=msoFalse)
                    Loop
                Next j
            Next i
        End If
 
	If shp.Type = msoGroup Or shp.Type = 24 Then
            For g = 1 To shp.GroupItems.Count
                txt_r = shp.GroupItems(g).TextFrame.TextRange.Text
                Set foundText = shp.GroupItems(g).TextFrame.TextRange.Find(FindWhat:=ToBeReplaced, WholeWords:=msoFalse)
                Do While Not (foundText Is Nothing)
                    NbCar = shp.GroupItems(g).TextFrame.TextRange.Characters.Count
                    NbCarToBeReplaced = Len(ToBeReplaced)
                    Do While iCar <= NbCar
                        myPos = InStr(iCar, txt_r, ToBeReplaced)
                        If myPos > 0 Then
                        iCar = myPos + NbCarToBeReplaced + 1
                        NbRemp = NbRemp + 1
                        Else: Exit Do
                        End If
                    Loop
                    Set foundText = shp.GroupItems(g).TextFrame.TextRange.Replace(FindWhat:=ToBeReplaced, replacewhat:=Replaceby, WholeWords:=msoFalse)
                    ' passer au suivant
                    Set foundText = shp.GroupItems(g).TextFrame.TextRange.Find(FindWhat:=ToBeReplaced, WholeWords:=msoFalse)
                Loop
            Next g
        End If
    Next shp
Next sld
MsgBox NbRemp & " remplacements"
End Sub
 
 
¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
 
 
 
Sub ReplaceAll(ToBeReplaced As String, Replaceby As String)
 
Dim sld As Slide
Dim grpItem As Shape
Dim shp As Shape
Dim i As Long
Dim j As Long
 
For Each sld In ActivePresentation.Slides
	For Each shp In sld.Shapes
		If shp.HasTextFrame Then
			If shp.TextFrame.HasText Then
				shp.TextFrame.TextRange.Text = Replace(shp.TextFrame.TextRange.Text, ToBeReplaced, Replaceby)
			End If
		End If
 
		If shp.HasTable Then
			For i = 1 To shp.Table.Rows.Count
				For j = 1 To shp.Table.Columns.Count
					shp.Table.Rows.Item(i).Cells(j).Shape.TextFrame.TextRange.Text = _
					Replace(shp.Table.Rows.Item(i).Cells(j).Shape.TextFrame.TextRange.Text, ToBeReplaced, Replaceby)
				Next j
			Next i
		End If
 
		If shp.Type = msoGroup Or shp.Type = 24 Then
			For g = 1 To shp.GroupItems.Count
				If shp.GroupItems(g).HasTextFrame Then
					If shp.GroupItems(g).TextFrame.HasText Then
						shp.GroupItems(g).TextFrame.TextRange.Text = Replace(shp.GroupItems(g).TextFrame.TextRange.Text, ToBeReplaced, Replaceby)
					End If
				End If
			Next g
		End If
	Next shp
Next
End Sub

Madlax

Ponctuation automatique - Besoin d'optimisation

VBA PowerPoint

Discussions similaires

Partager

Partager