Refresh de Zones de userform à partir de cellule pose problème.

Bonjour,

j'ai un Userform qui pilote mon application.
Au démarrage j'affiche un compteur journalier (mis à zéro au départ) et un compteur cumulé ainsi que d'autres zones

les 2 compteurs sont stockés dans 2 cellules distinctes d'une feuille.

Je ne parviens pas à avoir l'affichage de ces 2 zones (FAx_Sent, Fax_Sent_Cumulated) qui se met à jour sur mon userform alors que pour les autrez zones, il n'y a pas de problème.
A l'initialisation du userform, les données sont aussi correctes.
Le traitement est activé par un bouton start_polling sur le userform

Voici le code :
Dans Userform2
Code:

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 Private Sub UserForm_Initialize() Me.StartUpPosition = 3 'Fax Sent Worksheets("Parms").Range("C20") = 0 Me.Fax_Sent = Worksheets("Parms").Range("C20") 'Fax Sent Cumulated Me.Fax_Sent_Cumulated = Worksheets("Parms").Range("C21") Search_file = Folder & Trim(Worksheets("Parms").Range("C3")) DoEvents Me.Repaint End Sub Private Sub Start_Polling_Click() '4. Loop until button Stop used Do While BStop = False Found_Entry = "" Found_Entry = Dir(Search_file, vbNormal) Do While Found_Entry <> "" And BStop = False ' Start the loop. Me.Status_text = "Sending " & Folder & Trim(Found_Entry) Sent_Status = Send_1_File(Folder, Found_Entry, Attachement_folder, Me.Debug_Sw, P_Phwnd, O_Attachement_file) If Not Sent_Status Then Exit Sub Me.Last_File_Name = Folder & Trim(Found_Entry) Worksheets("Parms").Range("C20") = Worksheets("Parms").Range("C20") + 1 Me.Fax_Sent = Worksheets("Parms").Range("C20") Worksheets("Parms").Range("C21") = Worksheets("Parms").Range("C21") + 1 Me.Fax_Sent_Cumulated = Worksheets("Parms").Range("C21") Me.Status_text = "Waiting 2 sec before next entry" Application.Wait (Now + TimeValue("0:00:02")) Found_Entry = Dir ' Get next entry. Loop If BStop = False Then Me.Status_text = "Waiting 10 sec before Polling" Application.Wait (Now + TimeValue("0:00:10")) End If DoEvents Loop
Pour les autres zones (par exemple Status_text), cela fonctionne.

Et parfois, le compteur s'affiche quelques occurences, puis plus rien.

je ne comprends rien.:evilred::aie::arf:

Citation:

Envoyé par Godzestla

Voici le code :
Dans ThisWorkbook

Dans ThisWorkBook?

PGZ

Oops.

Bien sûr que non. C'est dans le userform.

Je corrige de ce pas.

Désolé !! :oops:

Bonjour.

As-tu esayé de faire Repaint dans ta procédure?

PGZ

Oui, je l'avais avant mais cela semblait provoquer une certaine instabilité car l'application tourne en permanence et à un certain moment le PC plantait.

Dans un précédent post, Zazaraignée m'avait conseillé d'enlever les Repaint.

J'ai essayé de mettre repaint sur le contrôle

Code:

Me.Fax_Sent.Repaint

mais cela ne semble pas supporté.

Je trouve quand même étrange que les autres contrôles se mettent bien à jour sans repaint.

Ce n'est qu'un avis mais je pense que tes pb viennent des instructions WAIT qui arrêtent toute exécution. Tu pourrais essayer :
- soit de remplacer par une boucle qui teste l'heure et passe sur un DoEvents
- soit de restructurer et utiliser OnTime.

PGZ

Citation:

Envoyé par pgz

Tu pourrais essayer :
- soit de remplacer par une boucle qui teste l'heure et passe sur un DoEvents
- soit de restructurer et utiliser OnTime.

merci.
je n'y connais rien à ces 2 solutions.
Tu n'as pas un exemple, même très court. ?:?

(Pour la petite histoire le premier wait et doevents sont là car l'application communique avec un serveur distant et la disponibilité des fichiers ainsi que l'activitation de delete par exemple ne sont pas immédiats.

J'ai testé jusqu'à trouver un timing qui semble correct. Sans le wait, mon code n'était pas en phase avec les objects à traiter.

Pour le second, c'est juste histoire d'insérer une temporisation cohérente avant l'exécution du polling suivant car s'il n'y a rien en input, rien ne sert de contrôler en live et en permanence.

NB : j'ai remis le repaint en sortie de la boucle 1 en testant que je ne l'ai pas fait juste avant (traité quelquechose dans la boucle 1)

La mise à jour des zones semble au point, mais pour la stabilité il faut voir comment le code va se comporter après quelques heures/jours.

Citation:

Envoyé par Godzestla

je n'y connais rien à ces 2 solutions.
Tu n'as pas un exemple, même très court. ?:?

Je préfère t'orienter vers le OnTime. Voici un exemple très simple, compter les secondes
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 Private Sub CommandButton1_Click() Dim i As Integer For i = 1 To 5 Me.TextBox1 = i Application.Wait Now + TimeValue("00:00:01") Next i End Sub Private Sub UserForm_Initialize() Me.TextBox1 = "début" End Sub
Pour supprimer le wait, dans le module du userform
Code:

1 2 3 4 5 6 7 Private Sub CommandButton2_Click() Call subTraiteLaunch End Sub Private Sub UserForm_Initialize() Me.TextBox1 = "début" End Sub
et dans un module standard
Code:

1 2 3 4 5 6 7 8 9 10 11 12 Private j As Integer Public Sub subTraiteLaunch() j = 0 Call subTraiteOnTime End Sub Public Sub subTraiteOnTime() j = j + 1 UserForm1.TextBox1 = j If j < 5 Then Application.OnTime Now + TimeValue("00:00:01"), "subTraiteOnTime" End Sub
Ca fait la même chose, mais l'exécution du code n'est pas arrêtée.

PGZ

Merci bien.

Je comprends le système (dans mon esprit, cela ressemble à du récursif)

Je souhaite pouvoir faire varier la limite d'attente en fonction de l'instruction du code effectuée.
Tu penses que je peux passer un paramètre dans
Code:

1 2 expression.OnTime(EarliestTime, Procedure (limite as integer), LatestTime, Schedule)
Sinon, si je passe par une variable globale qui servirait de limite, cela pourrait marcher ?
Code:

1 2 if j < limite_globale application.ontime .....

Je ne pense pas qu'on puisse passer un argument. J'utiliserais comme tu le suggères une variable commune de portée suffisante.

PGZ

Voilà,
je l'ai fait mais je suis surpris du résultat :

j'explique :

Tout début de Module1
Code:

1 2 3 4 Option Explicit Dim Limit_Wait As Integer Dim Current_Wait As Integer
En fin de module1
Code:

1 2 3 4 5 6 7 8 9 10 11 12 Public Sub WaitLaunch(delay As Integer) Limit_Wait = delay Current_Wait = 0 Call WaitOnTime End Sub Public Sub WaitOnTime() Current_Wait = Current_Wait + 1 UserForm2.Current_Wait = Current_Wait If Current_Wait < Limit_Wait Then Application.OnTime Now + TimeValue("00:00:01"), "WaitOnTime" End Sub
Un exemple d'appel dans le code
Code:

1 2 WaitLaunch (10)
Le curseur clignote en permanence et la machine travaille à tout casser.
Quand je mets Debug.print Current_Wait, Limit_Wait avant le if de WaitOnTime, la valeur de Current_Wait monte jusque 255 (je crois) mais la limite est correcte.

Je ne vois pas ou est mon erreur. Les appels récusrifs devraient s'arrêter à 10 ? non ?

Je ne vois pas d'erreur à ton code. Du coup j'ai fait un test qui l'utilise et cela marche très bien.

Il doit y avoir un pb ailleurs. Question bête : tu as des procédures évènementielles sur ta textbox?

PGZ

Non rien de chez rien.

Mon userform présente 1 bouton start et 1 bouton stop.

Tout le reste (textbox) est purement affichage.

Pour info, voci le code complet modifié selon ta proposition. La routine .ontime est tout en bas.

(Ce n'est pas ce code qui tourne en production mais celui avec .wait et le repaint. Celui-là semble stable pour l'instant (depuis hier soir).)

Encore merci pour ton temps.

Thisworkbook

Code:

1
2
3
4
 
Private Sub Workbook_Open()
relaunch
End Sub

userform2

Code:

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
 
Dim BStop As Boolean
 
 
 
Private Sub UserForm_Initialize()
Me.StartUpPosition = 3
 'Disable
Me.Stop_Polling.Visible = False
'Enable
Me.Start_Polling.Visible = True
Me.Open_Parm_Userform.Visible = True
'text
Me.Status_text = "*Stopped"
'last File
Me.Last_File_Name = ""
'Scanning_name
Me.Scanning_Name = ""
 
'Wait Time
Me.Current_Wait = 0
 
'Fax Sent
Worksheets("Parms").Range("C20") = 0
Me.Fax_Sent = Worksheets("Parms").Range("C20")
'Fax Sent Cumulated
Me.Fax_Sent_Cumulated = Worksheets("Parms").Range("C21")
 
Search_file = Folder & Trim(Worksheets("Parms").Range("C3"))
 
 
DoEvents
Me.Repaint
 
'Retrieve Debug_mode
Me.Debug_Sw = Worksheets("Parms").Range("C22")
 
End Sub
 
Private Sub Open_Parm_Userform_Click()
If Me.Password <> "Secret1" Then
 MsgBox "Please Specify a valid password at the right of this button and retry", vbCritical
 Else
  UserForm1.Show
  'Retrieve Debug_mode
  Me.Debug_Sw = Worksheets("Parms").Range("C22")
End If
End Sub
 
Private Sub Start_Polling_Click()
Dim Folder  As String               'Folder To browse
Dim Search_file As String           'Pattern File to search for in Folder
Dim Found_Entry As String           'Found File name
Dim Fullname    As String           'FullName of Found File
Dim Rech        As String
Dim Found_keys  As Boolean
Dim Pos_REF     As Integer          'Position of first **REF in record
Dim elem        As Integer
Dim ref         As String
Dim refx        As String
Dim Mail        As String
Dim Mailcc      As String
Dim Mailbcc     As String
Dim Subject     As String
Dim Body()      As String
Dim BSize       As Integer
Dim Attachement_folder As String    'Folder where to store attachement
Dim Attachement() As String
Dim Attachement_ext As String
Dim Attachement_brut As String
Dim O_Attachement_file As String
Dim Mxattach_name    As String
Dim Operation   As String
Dim Pdf_file    As String
Dim Ps_file     As String
Dim res         As Boolean
Dim shell_res   As Variant
Dim lng         As Integer
Dim Laligne As String, tablKeys As Variant, tablVar As Variant
Dim Where_pos As Long
Dim End_Where As Long
Dim beg_ligne As String
Dim End_ligne As String
Dim msg       As Variant
Dim Pass_Type As Boolean
 
Dim Sent_Status As Boolean
 
Dim P_Phwnd   As Long
 
 
 
 
 
'Mapping X pour attachement
map_mxattach
 
 
'Disable
Me.Start_Polling.Visible = False
Me.Open_Parm_Userform.Visible = False
Me.Password.Visible = False
'Enable
Me.Stop_Polling.Visible = True
'text
Me.Status_text = "Polling"
 
Me.Started_Box = "Started at " & CStr(Now())
 
BStop = False
 
'*****************************************************************
'* Send PDF Labels Using FAX*STAR                                *
'*****************************************************************
 
'1. Retrieve Folder to browse
 
Folder = Worksheets("Parms").Range("C2")
If Right(Folder, 1) <> "\" Then
    Folder = Trim(Folder) & "\"
End If
 
'2. Retrieve Pattern File to browse
 
Search_file = Folder & Trim(Worksheets("Parms").Range("C3"))
Me.Scanning_Name = Search_file
Me.Repaint
 
 
'3. Retrieve Folder where to store attachement for FAXSTAR (MXATTACH)
 
Attachement_folder = Trim(Worksheets("Parms").Range("C4"))
If Right(Attachement_folder, 1) <> "\" Then
    Attachement_folder = Trim(Attachement_folder) & "\"
End If
 
'4. Loop until button Stop used
 
Do While BStop = False
 
 DoEvents
 'text
 Me.Status_text = "Polling"
 '5. Browse Folder until end of sources files or Button Stop used.
 
 Found_Entry = ""
 On Error Resume Next
 Found_Entry = Dir(Search_file, vbNormal)
 If Err.Number = 52 Then
   msg = MsgBox("Connection to I5 lost. Application must be closed. Click <ok> to quit and please relaunch", vbCritical)
   ThisWorkbook.Save
   Application.Quit
 End If
 
  Pass_Type = False
  Do While Found_Entry <> "" And BStop = False   ' Start the loop.
 
    Me.Status_text = "Sending " & Folder & Trim(Found_Entry)
    Worksheets("Parms").Range("C20") = Worksheets("Parms").Range("C20") + 1
    Me.Fax_Sent = Worksheets("Parms").Range("C20")
    Worksheets("Parms").Range("C21") = Worksheets("Parms").Range("C21") + 1
    Me.Fax_Sent_Cumulated = Worksheets("Parms").Range("C21")
    Sent_Status = Send_1_File(Folder, Found_Entry, Attachement_folder, Me.Debug_Sw, P_Phwnd, O_Attachement_file)
    If Not Sent_Status Then Exit Sub
 
    Me.Last_File_Name = Folder & Trim(Found_Entry)
 
 
    Pass_Type = True
 
 
     Me.Status_text = "Waiting 2 sec before next entry"
     WaitLaunch (2)
     'Application.Wait (Now + TimeValue("0:00:02"))
     Found_Entry = Dir       ' Get next entry.
   Loop
 
   If Pass_Type Then
      Me.Repaint
   End If
 
   If BStop = False Then
     Me.Status_text = "Waiting 10 sec before Polling"
     WaitLaunch (10)
     'Application.Wait (Now + TimeValue("0:00:10"))
     'Me.Repaint
   End If
   DoEvents
 Loop
 
'Close View Last Attachment and remove it
If O_Attachement_file <> "" Then
   Me.Status_text = "Removing " & O_Attachement_file & " File"
   Me.Repaint
   If P_Phwnd <> 0 Then
     'Close default Viewer if openedt
     Call CloseProgram(P_Phwnd)
     DoEvents
   End If
   DoEvents
   Me.Repaint
   'If Not Me.Debug_Sw Then
      On Error Resume Next
      Kill O_Attachement_file
      Err.Clear
      DoEvents
   'End If
 
End If
O_Attachement_file = ""
PhWnd = 0
 
End Sub
 
Private Sub Stop_Polling_Click()
'Xl_plein_ecran
 
'Disable
Me.Stop_Polling.Visible = False
'Enable
Me.Start_Polling.Visible = True
Me.Open_Parm_Userform.Visible = True
Me.Password.Visible = True
'text
Me.Status_text = "*Stopped"
 
BStop = True
 
Me.Started_Box = "Stopped at " & CStr(Now())
End Sub

userform1

Code:

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
 
Private Sub Debug_Sw_Click()
'Save Debug_mode
Worksheets("Parms").Range("C22") = Me.Debug_Sw
 
End Sub
 
 
Private Sub ListBox1_Click()
For i = 0 To Me.ListBox1.ListCount - 1
 If Me.ListBox1.Selected(i) = True Then
    Worksheets("Parms").Range("C3") = Me.ListBox1.List(i)
    Exit For
 End If
Next i
End Sub
 
Private Sub Select_Folder_Input_Click()
Dim drive As String
Dim chemin As String
 
If Me.Folder_Input <> "" Then
    chemin = Me.Folder_Input
    drive = Left(chemin, 1)
    ChDrive drive
    ChDir chemin
End If
 
With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        .Title = "Sélectionnez le répertoire"
        .Show
If .SelectedItems.Count > 0 Then
    Me.Folder_Input = .SelectedItems(1)
    'Save Folder Input name selection
    Worksheets("Parms").Range("C2") = Me.Folder_Input
End If
 
End With
End Sub
 
Private Sub Select_Folder_MXattach_Click()
With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        .Title = "Sélectionnez le répertoire"
        .Show
If .SelectedItems.Count > 0 Then
    Me.Folder_Mxattach = .SelectedItems(1)
    'Save Folder Mxattach name selection
    Worksheets("Parms").Range("C4") = Me.Folder_Mxattach
End If
 
End With
End Sub
 
Private Sub Unload_Me_Click()
Unload Me
End Sub
 
Private Sub UserForm_Initialize()
 
'Retrieve Folder Input name selection
Me.Folder_Input = Worksheets("Parms").Range("C2")
 
'Init File Type Listbox and Retrieve File Type selection
Me.ListBox1.ColumnHeads = False
Me.ListBox1.RowSource = "Parms!A2:A4"
Me.ListBox1.MultiSelect = fmMultiSelectSingle
For i = 0 To Me.ListBox1.ListCount - 1
 If Me.ListBox1.List(i) = Worksheets("Parms").Range("C3") Then
    Me.ListBox1.Selected(i) = True
    Exit For
 End If
Next i
 
'Retrieve Folder Mxattach name selection
Me.Folder_Mxattach = Worksheets("Parms").Range("C4")
 
'Retrieve Debug_mode
Me.Debug_Sw = Worksheets("Parms").Range("C22")
 
 
End Sub

Module2

Code:

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
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
 
Option Explicit
 
'Flags ShellExecuteEx
Private Const SEE_MASK_NOCLOSEPROCESS = &H40
Private Const SEE_MASK_FLAG_NO_UI = &H400
 
'Constantes ERREUR ShellExecuteEx
Private Const SE_ERR_FNF As Byte = 2
Private Const SE_ERR_PNF As Byte = 3
Private Const SE_ERR_ACCESSDENIED As Byte = 5
Private Const SE_ERR_OOM As Byte = 8
Private Const SE_ERR_SHARE As Byte = 26
Private Const SE_ERR_ASSOCINCOMPLETE As Byte = 27
Private Const SE_ERR_DDETIMEOUT As Byte = 28
Private Const SE_ERR_DDEFAIL As Byte = 29
Private Const SE_ERR_DDEBUSY As Byte = 30
Private Const SE_ERR_NOASSOC As Byte = 31
Private Const SE_ERR_DLLNOTFOUND As Byte = 32
 
'Constantes AFFICHAGE ShellExecuteEx
Private Const SW_SHOWNORMAL = 1
Private Const SW_SHOW = 5
Private Const SW_SHOWDEFAULT = 10
 
Private Type SHELLEXECUTEINFO
    cbSize As Long
    fMask As Long
    hWnd As Long
    lpVerb As String
    lpFile As String
    lpParameters As String
    lpDirectory As String
    nShow As Long
    hInstApp As Long
    lpIDList As Long
    lpClass As String
    hkeyClass As Long
    dwHotKey As Long
    hIcon As Long
    hProcess As Long
End Type
 
'OpenProgram
Private Declare Function ShellExecuteEx Lib "shell32.dll" _
(SEI As SHELLEXECUTEINFO) As Long
 
 
'CloseProgram
Private Declare Function CloseHandle Lib "kernel32" _
(ByVal hObject As Long) As Long
 
Private Declare Function TerminateProcess Lib "kernel32" _
(ByVal hProcess As Long, ByVal uExitCode As Long) As Long
 
Private Declare Sub Sleep Lib "kernel32" _
(ByVal dwMilliseconds As Long)
 
Public Const WM_CLOSE = &H10
Const GW_HWNDNEXT = 2
Dim mWnd                    As Long
Dim PhWnd                   As Long
Dim P_Attachement_file      As String
Dim Limit_Wait              As Integer
Dim Current_Wait            As Integer
Private AppCible            As String
 
 
' ***********************************************************
' *
' * Lance le programme par défaut associé à un fichier (en fonction de son
' * extension ) et retourne le hWnd de la fênetre du programme lançé.
' *
' ***********************************************************
 
Public Function OpenProgram(ByRef Filename As String, ByRef OwnerhWnd As Long) As Long
    Dim SEI As SHELLEXECUTEINFO
 
    On Error GoTo ErrorHandler
 
    'Vérifie si le fichier à lancer est un exécutable (.exe)
    If GetExtension(Filename) = "exe" Then
        If vbNo = MsgBox("ATTENTION, êtes-vous sûr de vouloir lancer ce programme exécutable ?", vbExclamation + vbYesNo) _
        Then
            OpenProgram = 0
            Exit Function
        End If
    End If
 
    With SEI
        .cbSize = Len(SEI)
        .fMask = SEE_MASK_NOCLOSEPROCESS Or SEE_MASK_FLAG_NO_UI
        .hWnd = OwnerhWnd
        .lpVerb = "open"
        .lpFile = Filename
        .lpParameters = vbNullChar
        .lpDirectory = vbNullChar
        .nShow = SW_SHOW
        .hInstApp = OwnerhWnd
    End With
 
    OpenProgram = ShellExecuteEx(SEI)
 
    If SEI.hInstApp <= 32 Then
    'Erreurs
        OpenProgram = 0
 
        Select Case SEI.hInstApp
            Case SE_ERR_FNF
                OpenProgram = SEI.hProcess
            Case SE_ERR_PNF
                MsgBox "Le chemin du fichier à ouvrir est incorrect.", vbExclamation
            Case SE_ERR_ACCESSDENIED
                MsgBox "Accès au fichier refusé.", vbExclamation
            Case SE_ERR_OOM
                MsgBox "Mémoire insuffisante.", vbExclamation
            Case SE_ERR_DLLNOTFOUND
                MsgBox "Dynamic-link library non trouvé.", vbExclamation
            Case SE_ERR_SHARE
                MsgBox "Le fichier est déjà ouvert.", vbExclamation
            Case SE_ERR_ASSOCINCOMPLETE
                MsgBox "Information d'association du fichier incomplète.", vbExclamation
            Case SE_ERR_DDETIMEOUT
                MsgBox "Opération DDE dépassée.", vbExclamation
            Case SE_ERR_DDEFAIL
                MsgBox "Opération DDE echouée.", vbExclamation
            Case SE_ERR_DDEBUSY
                MsgBox "Opération DDE occupée.", vbExclamation
            Case SE_ERR_NOASSOC
                'Ouvrir avec...
                Call Shell("rundll32.exe shell32.dll,OpenAs_RunDLL " + Filename, vbNormalFocus)
        End Select
    Else
        'Retourne le hWnd du programme lançé par ShellExecuteEx
        OpenProgram = SEI.hProcess
    End If
 
    Exit Function
ErrorHandler:
    OpenProgram = 0
End Function
 
' ***********************************************************
' *
' * Ferme un programme à partir du hWnd de sa fenêtre.
' *
' ***********************************************************
 
Public Function CloseProgram(hWnd As Long) As Boolean
    Dim lExitCode As Long
 
    If hWnd = 0 Then
        Exit Function
    End If
 
    On Error Resume Next
    CloseProgram = CBool(TerminateProcess(hWnd, lExitCode))
    'On Error Resume Next
    CloseHandle hWnd
    DoEvents
    Sleep (100)
 
End Function
 
Public Function GetExtension(Filename As String) As String
Dim tablo() As String
tablo = Split(Filename, ".")
GetExtension = tablo(UBound(tablo))
End Function
 
Function Unquote(MyString As Variant) As Variant
Dim lng As Integer
lng = Len(Trim(MyString))
If lng > 2 Then
    Unquote = Mid(Trim(MyString), 2, lng - 2)
  Else
    Unquote = " "
End If
 
End Function
Sub Z_hide_Show_Parm()
Dim status As Boolean
If Worksheets("Parms").Range("C17") = True Then
    Worksheets("Parms").Range("C17") = False
 Else
    Worksheets("Parms").Range("C17") = True
End If
 
status = Worksheets("Parms").Range("C17")
Worksheets("Parms").Visible = status
End Sub
 
Function Send_1_File(Folder As String, Found_Entry As String, Attachement_folder As String, Debug_Sw As Boolean, P_Phwnd As Long, Attachement_file As String) As Boolean
 
Dim Fullname    As String           'FullName of Found File
Dim Rech        As String
Dim Found_keys  As Boolean
Dim Pos_REF     As Integer          'Position of first **REF in record
Dim elem        As Integer
Dim ref         As String
Dim refx        As String
Dim Mail        As String
Dim Mailcc      As String
Dim Mailbcc     As String
Dim Subject     As String
Dim Body()      As String
Dim BSize       As Integer
Dim Attachement() As String
Dim Attachement_ext As String
Dim Attachement_brut As String
Dim Mxattach_name    As String
Dim Destination      As String
Dim Operation   As String
Dim Pdf_file    As String
Dim Ps_file     As String
Dim res         As Boolean
Dim shell_res   As Variant
Dim lng         As Integer
Dim Laligne As String, tablKeys As Variant, tablVar As Variant
Dim Where_pos As Long
Dim End_Where As Long
Dim beg_ligne As String
Dim End_ligne As String
Dim Fax_file  As String
 
 
 
Send_1_File = True
 
 
'*****************************************************************
'* Send PDF Labels Using FAX*STAR                                *
'*****************************************************************
 
    Fullname = Folder & Found_Entry
    On Error Resume Next
    Open Fullname For Input As #1
    If Err.Number <> 0 Then
       MsgBox ("Error/" & Err.Number & " :" & Fullname & " not found. Process Halted")
       Send_1_File = False
       Exit Function
    End If
    Found_keys = False
    Line Input #1, Laligne
    Do While Not EOF(1) And Found_keys = False
      Pos_REF = InStr(1, Laligne, "**(REF)", vbTextCompare)
      If Pos_REF > 0 Then
        Found_keys = True
       Else
       Line Input #1, Laligne
      End If
    Loop
 
 
    ref = ""
    refx = ""
    Mail = ""
    Mailcc = ""
    Mailbcc = ""
    Subject = ""
    Attachement_brut = ""
    ReDim Body(1)
    BSize = 0
    Attachement_file = ""
    Ps_file = ""
    Fax_file = ""
 
    If Found_keys Then
        tablKeys = Split(Laligne, ",")
        Line Input #1, Laligne
        tablVar = Split(Laligne, ",")
 
        For elem = 0 To UBound(tablKeys)
            'Debug.Print Trim(tablKeys(elem)) & " - "; Trim(tablVar(elem))
            Select Case Trim(tablKeys(elem))
                Case "**(REF)"
                    ref = Trim(tablVar(elem))
                Case "**(REFX)"
                    refx = Trim(tablVar(elem))
                Case "**(MAIL)"
                    If Debug_Sw Then
                     Mail = "*caché car privé"
                    Else
                     Mail = Unquote(Trim(tablVar(elem)))
                    End If
                Case "**(MAILCC)"
                    If Not Debug_Sw Then
                     Mailcc = Unquote(Trim(tablVar(elem)))
                    End If
                Case "**(MAILBCC)"
                    If Not Debug_Sw Then
                     Mailbcc = Unquote(Trim(tablVar(elem)))
                    End If
                Case "**(SUBJECT)"
                    Subject = Trim(tablVar(elem))
                Case "**(BODY)", "**(BODY1)", "**(BODY2)", "**(BODY3)", "**(BODY4)", "**(BODY5)", "**(BODY6)", "**(BODY7)", "**(BODY8)", "**(BODY9)", "**(BODY10)"
                    BSize = BSize + 1
                    ReDim Preserve Body(BSize)
                    Body(BSize - 1) = Unquote(Trim(tablVar(elem)))
                Case "**MXATTACHD"
                    Attachement_brut = Unquote(Trim(tablVar(elem)))
                    Attachement = Split(Attachement_brut, ".")
                    Attachement_ext = Attachement(1)
                    Fax_file = Attachement(0) & "." & "INI"
                    If Attachement_ext = "PS" Then
                      Ps_file = Attachement_brut
                      Pdf_file = Attachement(0) & "." & "Pdf"
                      res = Application.Run("GSAPI_VBA.XLS!Convertfile", Attachement_brut, Pdf_file)
                      DoEvents
                      WaitLaunch (2)
                      'Application.Wait (Now + TimeValue("0:00:02"))
                      Attachement_brut = Pdf_file
                    End If
                    Attachement_file = Attachement_brut
                    'Move Attachement to Attachement_Folder
                    Attachement = Split(Attachement_brut, "\")
                    Destination = Attachement_folder & Attachement(UBound(Attachement))
                    Mxattach_name = Attachement(UBound(Attachement))
                    On Error Resume Next
                    FileCopy Attachement_brut, Destination
                    If Err.Number <> 0 Then
                      MsgBox ("Error/" & Err.Number & " :" & Destination & " Path/drive not available. Process Halted")
                      Err.Clear
                      Close #1
                      Send_1_File = False
                      Exit Function
                    End If
                    'Close View Previous Attachment and remove it
                    If P_Attachement_file <> "" Then
                       If PhWnd <> 0 Then
                         'Close default Viewer if openedt
                         Call CloseProgram(PhWnd)
                         DoEvents
                       End If
                       WaitLaunch (10)
                       'Application.Wait (Now + TimeValue("0:00:10"))
                       'On Error Resume Next
                       'If Not Debug_Sw Then
                         Kill P_Attachement_file
                         Err.Clear
                       'End If
                       DoEvents
                    End If
                    P_Attachement_file = ""
                    PhWnd = 0
 
                    WaitLaunch (3)
                    'Application.Wait (Now + TimeValue("0:00:03"))
                    '*************************************
                    'Show Attachement With Default Viewer
                    PhWnd = OpenProgram(Attachement_file, 0)
                    P_Phwnd = PhWnd
 
                    'Excel premier Plan
                    AppActivate "Microsoft Excel"
                    DoEvents
 
            End Select
        Next
 
        'Formattage Fichier sortie
        If Mail <> "" And Attachement_brut <> "" Then
           Open Fax_file For Output As #2
           Laligne = "**(REF) " & ref
           Print #2, Laligne
           If refx <> "" Then
              Laligne = "**(REFX) " & refx
              Print #2, Laligne
           End If
           Laligne = "**(MAIL) " & Mail
           Print #2, Laligne
           If Mailcc <> "" Then
              Laligne = "**(MAILCC) " & Mailcc
              Print #2, Laligne
           End If
           If Mailbcc <> "" Then
              Laligne = "**(MAILBCC) " & Mailbcc
              Print #2, Laligne
           End If
           If Subject <> "" Then
              Laligne = "**(SUBJECT) " & Subject
              Print #2, Laligne
           End If
           For elem = 1 To BSize
              Laligne = Trim(Body(elem - 1))
              Print #2, Laligne
           Next
           Print #2, " "
           Laligne = "**MXATTACHD " & Mxattach_name
           Print #2, Laligne
           Print #2, " "
           Close #2
           Operation = "lpr -S 149.209.142.14 -P faxstar " & Fax_file
           shell_res = Shell(Operation, vbNormalFocus)
           DoEvents
          Else
            Close #2
        End If
    End If
    Close #1
 
    'If Not Me.Debug_Sw Then
       On Error Resume Next
       Kill Fullname
       DoEvents
    'End If
 
    If Ps_file <> "" Then
        'If Not Debug_Sw Then
          On Error Resume Next
          Kill Ps_file
          DoEvents
          Err.Clear
         'End If
    End If
 
    WaitLaunch (10)
    'Application.Wait (Now + TimeValue("0:00:10"))
    If Fax_file <> "" Then
        On Error Resume Next
        Kill Fax_file
        DoEvents
        Err.Clear
    End If
 
    'Backup Attachement name
    P_Attachement_file = Attachement_file
 
 
 
End Function
 
 
 
Sub map_mxattach()
Dim Operation   As String
Dim shell_res   As Variant
 
Operation = "net use X: \\149.209.142.14\faxstar_xattach /PERSISTENT:NO "
shell_res = Shell(Operation, vbNormalFocus)
DoEvents
End Sub
 
Sub Xl_réduit()
'réduit la fenêtre et la positionne
'dans le coin supérieur gauche
    With Application
        .WindowState = xlNormal
        .Height = UserForm2.Height
        .Width = UserForm2.Width
        .Top = 0
        .Left = 0
    End With
End Sub
 
Sub Xl_plein_ecran()
'redimensionne la fenêtre en plein écran
    Application.WindowState = xlMaximized
End Sub
 
Sub relaunch()
Worksheets("Sheet1").Activate
'Réduit Excel'
Xl_réduit
UserForm2.Show
Xl_plein_ecran
End Sub
 
Public Sub WaitLaunch(delay As Integer)
Limit_Wait = delay
Current_Wait = 0
Call WaitOnTime
End Sub
 
Public Sub WaitOnTime()
Current_Wait = Current_Wait + 1
UserForm2.Current_Wait = Current_Wait
If Current_Wait < Limit_Wait Then Application.OnTime Now + TimeValue("00:00:01"), "WaitOnTime"
End Sub

Bonjour Godzelsta.

Je vois un problème de structure dans l'application de l'idée. Il me paraît normal que cela ne fonctionne pas bien.
Dès que j'aurais un peu de temps, je te proposerai une modification du code. Si la solution vaec Wait fonctionne maintenant, il n'y a pas d'urgence...

A plus,

PGZ

Merci.

Prends ton temps.
A+