Discussion :

[Kero87]

Bonjour à tous,

J'ai un souci avec l'évènement Document_ContentControlOnExit: J'ai une macro qui se lance à chaque fois qu'on quitte une boîte de contrôle. La macro fonctionne correctement dans l'ensemble. Mais, de temps en temps (env. 1 fois sur 5), une fois la macro finie, la sélection retourne à la boîte de contrôle qui vient d'être quittée. Je me retrouve alors dans une boucle sans fin: je quitte la boîte, la macro se lance, la sélection revient à la boîte, je re-quitte la boîte, la macro se relance, la sélection revient à nouveau à la boîte...
Pourtant, je ne pense pas faire quoi que ce soit à l'argument "Cancel" (en fait, je le force même à "False" à la fin de la macro). De même, s'il y a une partie de mon code qui re-sélectionne la boîte, je n'ai pas trouvé laquelle.
Si quelqu'un a une idée...

Version de Word: Office Standard 2016

Macro dans le module du document:

Code :

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

1
2
3
4
5
6
7
8
9
Option Explicit
 
 
Private Sub Document_ContentControlOnExit(ByVal ContentControl As ContentControl, Cancel As Boolean)
 
Call ModMajTableaux.MajTableaux(ContentControl)
Cancel = False
 
End Sub

Module ModMajTableaux:

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
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
Option Explicit
 
Private Enum ColTabMesures
    ColDim1 = 4
    ColDim2
    ColDelta
    End Enum
 
Private Enum ColTabCc
    ColDeltaMax = 4
    ColIT
    ColOk
    End Enum
 
Private Enum Statut
    Invalide = -1
    Nok = 0
    Ok = 1
    End Enum
 
Dim Doc As Document
Dim CtlSelec As ContentControl
Dim Lig As Integer
 
'Tableau de mesures 1
Private Const NomSignetTab1 As String = "Tableau1"
Dim Tab1 As Table
 
'Tableau de mesures 1
Private Const NomSignetTab2 As String = "Tableau2"
Dim Tab2 As Table
 
'Tableau de conclusions:
Private Const NomSignetTabCc As String = "TableauCc"
Dim TabCc As Table
 
 
Public Sub MajTableaux(ByVal mCtlSelec As ContentControl)
 
Dim Selec As Range
Dim Delta1 As Single, Delta2 As Single
 
If mCtlSelec.Range.Information(wdWithInTable) = False And _
    Not (mCtlSelec.Type = wdContentControlText Or mCtlSelec.Type = wdContentControlRichText) Then
    Exit Sub
    End If
 
Set Doc = ThisDocument
Set CtlSelec = mCtlSelec
Set Selec = CtlSelec.Range
Selec.Select
 
Set Tab1 = DefinirTableau(NomSignetTab1)
    If Tab1 Is Nothing Then Exit Sub
Set Tab2 = DefinirTableau(NomSignetTab2)
    If Tab2 Is Nothing Then Exit Sub
Set TabCc = DefinirTableau(NomSignetTabCc)
    If TabCc Is Nothing Then Exit Sub
 
Lig = LigSelec(Selec)
If Lig < 2 Then Exit Sub
 
Delta1 = CalculDelta(Tab1, Lig)
Delta2 = CalculDelta(Tab2, Lig)
 
Call MajTableauCc(Delta1, Delta2)
 
End Sub
 
 
Private Function DefinirTableau(ByVal NomSignet As String)
 
Dim mTab As Table
Dim Signet As Bookmark, SignetOK As Boolean
 
For Each Signet In Doc.Bookmarks
    If Signet.Name = NomSignet Then
        SignetOK = True
 
        Select Case Signet.Range.Tables.Count
            Case 0
                MsgBox Prompt:="The Bookmark '" & NomSignet & "' contains no table.", _
                       Title:="Undefined Table"
            Case 1
                Set mTab = Signet.Range.Tables(1)
 
            Case Else
                MsgBox Prompt:="The Bookmark '" & NomSignet & "' contains more than one table.", _
                       Title:="Undefined Table"
            End Select
 
        Exit For
        End If
    Next Signet
 
If SignetOK = False Then MsgBox ("No Bookmark '" & NomSignet & "' found.")
 
Set DefinirTableau = mTab
 
End Function
 
Private Function CalculDelta(ByRef mTab As Table, ByVal Lig As Integer) As Single
 
Dim mDelta As Single
Dim Dim1 As Single, Dim2 As Single
Dim DimOk As Boolean
Dim cDelta As Cell
 
Set cDelta = mTab.Cell(Lig, ColDelta)
 
DimOk = False
With mTab.Cell(Lig, ColDim1).Range.ContentControls
    If .Count > 0 Then Dim1 = ExtraireValNumDeCtl(.Item(1))
    End With
With mTab.Cell(Lig, ColDim2).Range.ContentControls
    If .Count > 0 Then Dim2 = ExtraireValNumDeCtl(.Item(1))
    End With
If Dim1 > 0 And Dim2 > 0 Then
    DimOk = True
    End If
 
If DimOk = True Then
    mDelta = Round(Abs(Dim1 - Dim2), 2)
    cDelta.Range.Text = Replace(CStr(mDelta), ",", ".")
 
    Else
        mDelta = -1
        cDelta.Range.Text = ""
    End If
 
CalculDelta = mDelta
 
End Function
 
 
Private Sub MajTableauCc(ByVal Delta1 As Single, Delta2 As Single)
 
Dim DeltaMax As Single, DeltaMaxOk As Statut, cDeltaMax As Cell
Dim IT As Single, cIT As Cell
Dim Cc As String, cCc As Cell
 
Set cCc = TabCc.Cell(Lig, ColOk)
 
IT = ExtraireValNumDeCel(TabCc.Cell(Lig, ColIT))
If Delta1 > Delta2 Then
    DeltaMax = Delta1
    Else
        DeltaMax = Delta2
    End If
 
If Delta1 < 0 And Delta2 < 0 Then
    DeltaMaxOk = Invalide
 
    ElseIf Delta1 < 0 Then
        If DeltaMax < IT Then
            DeltaMaxOk = Invalide
            Else
                DeltaMaxOk = Nok
            End If
 
    ElseIf Delta2 < 0 Then
        If DeltaMax < IT Then
            DeltaMaxOk = Invalide
            Else
                DeltaMaxOk = Nok
            End If
 
    ElseIf Delta1 >= 0 And Delta2 >= 0 Then
        If DeltaMax < IT Then
            DeltaMaxOk = Ok
            Else
                DeltaMaxOk = Nok
            End If
 
    End If
 
Set cDeltaMax = TabCc.Cell(Lig, ColDeltaMax)
 
 
Select Case DeltaMaxOk
 
    Case Invalide
        cDeltaMax.Range.Text = ""
        With cCc
            .Range.Text = ""
            .Shading.Texture = wdTextureNone
            .Shading.BackgroundPatternColor = wdColorAutomatic
            End With
 
    Case Ok
        cDeltaMax.Range.Text = Replace(CStr(DeltaMax), ",", ".")
        With cCc
            .Range.Text = "OK"
            .Shading.BackgroundPatternColor = wdColorGreen
            End With
 
    Case Nok
        cDeltaMax.Range.Text = Replace(CStr(DeltaMax), ",", ".")
        With cCc
            .Range.Text = "NOK"
            .Shading.BackgroundPatternColor = wdColorRed
            End With
 
    End Select
 
 
End Sub
 
Private Function TabSelectionne(ByVal Selec As Range) As Table
 
Dim mTab As Table
 
If Selec.InRange(Tab1.Range) Then Set mTab = Tab1
If Selec.InRange(Tab2.Range) Then Set mTab = Tab2
 
Set TabSelectionne = mTab
 
End Function
 
 
Private Function LigSelec(ByVal Selec As Range) As Integer
 
Dim mTab As Table
Dim mLig As Row, BonneLig As Integer
 
Set mTab = TabSelectionne(Selec)
If mTab Is Nothing Then
    BonneLig = 0
    Else
 
        If SelDsColDim(Selec, mTab) = False Then
            BonneLig = 0
            Else
 
                For Each mLig In mTab.Rows
                    If Selec.InRange(RangeLig(mLig)) Then
                        BonneLig = mLig.Index
                        Exit For
                        End If
                    Next mLig
 
            End If
 
    End If
 
LigSelec = BonneLig
 
End Function
 
 
Private Function SelDsColDim(ByVal Selec As Range, ByVal Tableau As Table) As Boolean
 
Dim DsCol As Boolean
Dim mCol As Column, PlCol1 As Range, PlCol2 As Range
 
Set PlCol1 = RangeColonne(Tableau.Columns(ColDim1))
Set PlCol2 = RangeColonne(Tableau.Columns(ColDim2))
If Selec.InRange(PlCol1) Or Selec.InRange(PlCol2) Then
    DsCol = True
    Else
        DsCol = False
    End If
 
SelDsColDim = DsCol
 
End Function
 
Private Function ExtraireValNumDeCtl(ByVal mCtl As ContentControl) As Single
 
Dim mTxt
Dim mNum As Single
 
mTxt = Trim(mCtl.Range.Text)
mTxt = Replace(mTxt, ".", ",")
Do While Left(mTxt, 1) = "_"
    mTxt = Right(mTxt, Len(mTxt) - 1)
    Loop
Do While Right(mTxt, 1) = "_"
    mTxt = Left(mTxt, Len(mTxt) - 1)
    Loop
mTxt = Trim(mTxt)
 
If mTxt = "" Then
    mNum = -1
 
    Else
        If IsNumeric(mTxt) Then
            mNum = Round(mTxt, 2)
 
            Else
                mNum = -1
                MsgBox ("The entered value ('" & mTxt & "') is not numeric.")
 
            End If
 
    End If
 
ExtraireValNumDeCtl = mNum
 
End Function
 
Private Function ExtraireValNumDeCel(ByVal Cel As Cell) As Single
 
Dim mTxt
Dim mNum As Single
 
mTxt = Cel.Range.Text
mTxt = Trim(Left(mTxt, Len(mTxt) - 2))
mTxt = Replace(mTxt, ".", ",")
 
If IsNumeric(mTxt) Then
    mNum = mTxt
 
    Else
        mNum = -1
        MsgBox ("Invalid Interval: " & mTxt)
 
    End If
 
ExtraireValNumDeCel = mNum
 
End Function
 
 
Private Function RangeColonne(ByVal Col As Column) As Range
 
Dim Pl As Range
 
With Col.Cells
    Set Pl = Doc.Range(.Item(1).Range.Start, .Item(.Count).Range.End)
    End With
 
Set RangeColonne = Pl
 
End Function
 
Private Function RangeLig(ByVal mLig As Row) As Range
 
Dim Pl As Range
 
With mLig.Cells
    Set Pl = Doc.Range(.Item(1).Range.Start, .Item(.Count).Range.End)
    End With
 
Set RangeLig = Pl
 
End Function

Objet de la macro:

Le document comprend (entre autres choses) deux tableaux de mesures (Tab1 et Tab2) et un tableau de conclusion (TabCc). Chacun de ces tableaux est inclus dans un signet ("Tableau1", "Tableau2", "TableauCc").
Les trois tableaux ont le même nombre de lignes. Chaque ligne correspond à un défaut de parallélisme à contrôler. Chaque défaut de parallélisme est contrôlé deux fois (d'où les deux tableaux de mesures).
À chaque fois que l'utilsateur entre une mesure dans un tableau de mesures, la macro met à jour la ligne où est entrée la mesure, dans les trois tableaux.
Chaque tableau de mesures comprend:

• une colonne où inscrire une première mesure (Dim1) dans une bôite de contrôle,
• une colonne où inscrire une deuxième mesure (Dim2) dans une boîte de contrôle,
• une colonne où la macro inscrit le défaut de parallélisme (Delta) calculé d'après les mesures susmentionnées.

Le tableau de conclusion comprend:

• une colonne où la macro inscrit la plus grande des deux mesures de parallélisme (DeltaMax),
• une colonne où est inscrit le défaut de parallélismé toléré (IT),
• une colonne où la macro inscrit la conclusion (Cc): "Ok" ou "Nok".

[Invité]

Bonjour,

Je ne vais pas forcément pouvoir vous aider sans votre document, mais il est possible que certaines actions se fassent plus rapidement que prévu dans le code. Pour éviter cela, on place à certains endroits des DoEvents pour contrôler la bonne exécution ( Exemple : cf MajTableaux avant lancement de MajTableauCc).

D'autre part, votre code contient de nombreuses variables objet qui ne sont jamais détruites et qui donc contiennent toujours des valeurs.
Pour ma part, j'applique la règle suivante : Toute variable instanciée dans une procédure est détruite dans la même procédure (à force d'avoir pas mal galéré pour chercher les erreurs). Si la variable est utilisée dans d'autres procédures ou fonctions, elle est passée par paramètre.

[Kero87]

Éric,

Merci beaucoup pour votre réponse.

J'ai tenté d'appliquer vos conseils. Si je ne me trompe pas, en VBA, une déclaration faite dans une sub ne vaut que le temps où la sub est en cours. Du coup, j'ai interprété vos recomendations en "déclarer les pointeurs des objets dans une sub/fonction plutôt qu'en tête de module, puis, si besoin, les passer en arguments à d'autres fonctions/sub". Il n'y a guère que les variables Tab1 et Tab2 (non-utiles passées la première moitié de la sub principale), auxquelles j'ai passé "Nothing".
Par contre, je n'ai pas touché au constantes et Enum.
C'était ça l'idée ou j'ai compris de travers?

J'ai aussi trouvé un "select" qui était passé entre les mailles du filet lors de ma relecture.

Pas eu besoin des DoEvents.

Maintenant, mon fichier fonctionne correctement. Quant à savoir si c'est grâce à la suppression du select inopportun ou au "nettoyage" des variables objet...

[Invité]

Ravi que tu aies réglé ton problème.

Sinon, je ne suis sûr de rien car tout est basé sur l'expérience et l'habitude... Un Set XXXX dans une procédure = Un Set XXXX = Nothing dans la même procédure = Pas de saturation de pile et pas de message "Mémoire insuffisante". Sinon, cela m'arrive de mettre régulièrement des DoEvents dans mes codes, mais je ne sais pas si le problème vient de la rapidité du micro ou non.

Tant mieux si ça fonctionne, il n'y a que le résultat qui compte.

Bon courage.