[XL-2007] Fermeture intempestive de l'userform dès que je rajoute, du code, textbox, etc.

re bonjour patricktoulon,
bonjour corona et au forum

J'utilise des variables publics et des fonctions dans des modules.

Voici les codes pour :
Client

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
Option Explicit
 
Private Sub adr_Change()
If Label58 = "Nouveau" Then VérifExistence
    With Me.adr
        .BorderStyle = 0: .BorderColor = RGB(165, 165, 165): .BackColor = RGB(255, 255, 192): .SpecialEffect = fmSpecialEffectSunken
    End With
End Sub
 
Private Sub CheckBox1_Click()
If CheckBox1 = True Then Feuil11.Range("G9") = "VRAI" Else Feuil11.Range("G9") = "FAUX"
End Sub
 
Private Sub ComboBox3_Change()
Dim aa
If ComboBox3 = "Client" Then
aa = Feuil9.Range("c2:c" & Feuil9.Range("c6500").End(xlUp).Row)
Me.ComboBox4.Visible = True
Label38.Visible = True
Else
aa = Feuil18.Range("d2:d" & Feuil18.Range("d6500").End(xlUp).Row)
End If
ComboBox4.List = aa
End Sub
 
Private Sub ComboBox6_Change()
 
Application.ScreenUpdating = True
Select Case ComboBox6.Value
        Case "Particulier", "Association"
                ComboBox7 = ComboBox6.Value
        Case "Société", "Administration", "Entreprise"
                ComboBox7 = "Professionnel"
        Case "Autre"
                ComboBox7 = ""
End Select
 
If ComboBox6 = "Particulier" Then
    Me.cp.Visible = False
    Label3.Visible = False
    Me.ComboBox8.Visible = False
    Label44.Visible = False
    Me.tel.Visible = False
    Label26.Visible = False
    Me.maill.Visible = False
    Label27.Visible = False
    web.Visible = True 'Affiche contenu Site Web
Else
    Me.cp.Visible = True
    Label3.Visible = True
    Me.ComboBox8.Visible = True
    Label44.Visible = True
    Me.tel.Visible = True
    Label26.Visible = True
    Me.maill.Visible = True
    Label27.Visible = True
    web.Visible = False
    End If
End Sub
 
Private Sub CommandButton1_Click()
Dim r, Y As Long
Dim ob As Control
If adr = "" Then
MsgBox "Merci de compléter le nom du nouveau client avant de saisir les autres données !"
    With Me.adr
        .BorderStyle = 1: .BackColor = RGB(241, 221, 220): .BorderColor = RGB(255, 0, 0): .SpecialEffect = fmSpecialEffectSunken
        .SetFocus
    End With
Exit Sub
End If
For Each ob In Me.Controls
If ob.Tag > "" Then
Select Case Val(ob.Tag)
Case 16, 17, 1
Feuil9.Cells(gg, Val(ob.Tag)) = Val(ob)
Case 31, 23
If IsDate(ob) = True Then Feuil9.Cells(gg, Val(ob.Tag)) = CDate(ob) Else Feuil9.Cells(gg, Val(ob.Tag)) = ""
Case Else
Feuil9.Cells(gg, Val(ob.Tag)) = ob
End Select
End If
Next
dico1
dep.client.Clear
If dep.TextBox9 = "" Then
For r = 2 To finf9
dep.client.AddItem Feuil9.Cells(r, 1) & " " & Feuil9.Cells(r, 3) & " (" & Feuil9.Cells(r, 4) & ")"
dep.client.List(r - 2, 1) = r
Next
dep.client = gg
Else
For r = 2 To finf9
If UCase(Mid(Feuil9.Cells(r, 3), 1, Len(dep.TextBox9))) = UCase(dep.TextBox9) Then
dep.client.AddItem Feuil9.Cells(r, 1) & " " & Feuil9.Cells(r, 3) & " (" & Feuil9.Cells(r, 4) & ")"
dep.client.List(Y, 1) = r
Y = Y + 1
End If
Next
End If
If Feuil11.Range("G9") = "VRAI" Then controleLastName_contactsOutlook
Unload Me
End Sub
 
Private Sub CommandButton2_Click()
Dim r
Feuil9.Rows(gg).Delete
dep.client.Clear
For r = 2 To finf9
dep.client.AddItem Feuil9.Cells(r, 1)
Next
clien.Hide
End Sub
 
Private Sub CommandButton25_Click()
ufCal.Show
If retourdate = "" Then Exit Sub
TextBox18 = retourdate
End Sub
 
Private Sub CommandButton26_Click()
ufCal.Show
If retourdate = "" Then Exit Sub
TextBox21 = retourdate
End Sub
 
Private Sub maill_Change()
maill.MaxLength = 17
If Len(maill) = 2 Or Len(maill) = 6 Or Len(maill) = 10 Or Len(maill) = 14 Then maill = maill & " "
End Sub
 
Private Sub tel_Change()
tel.MaxLength = 17
If Len(tel) = 3 Or Len(tel) = 7 Or Len(tel) = 11 Then tel = tel & " "
End Sub
 
Private Sub TextBox12_Change()
TextBox12.MaxLength = 14 'Nombre de caratères max
If Len(TextBox12) = 2 Or Len(TextBox12) = 5 Or Len(TextBox12) = 8 Or Len(TextBox12) = 11 Then TextBox12 = TextBox12 & "." 'Nombre de caractères entre les "/"
End Sub
 
Private Sub TextBox2_Change()
TextBox2.MaxLength = 14
If Len(TextBox2) = 2 Or Len(TextBox2) = 5 Or Len(TextBox2) = 8 Or Len(TextBox2) = 11 Then TextBox2 = TextBox2 & "."
End Sub
 
Private Sub TextBox3_Change()
TextBox3.MaxLength = 14
If Len(TextBox3) = 2 Or Len(TextBox3) = 5 Or Len(TextBox3) = 8 Or Len(TextBox3) = 11 Then TextBox3 = TextBox3 & "."
End Sub
 
Private Sub TextBox6_Change()
TextBox3.MaxLength = 11
If Len(TextBox6) = 3 Or Len(TextBox6) = 7 Then TextBox6 = TextBox6 & " "
End Sub
 
Private Sub TextBox7_Change()
TextBox7.MaxLength = 5
If Len(TextBox7) = 2 Then TextBox7 = TextBox7 & "."
End Sub
 
Private Sub TextBox8_Change()
TextBox8.MaxLength = 5
If Len(TextBox8) = 2 Then TextBox8 = TextBox8 & "'"
End Sub
 
Private Sub CommandButton3_Click()
Dim URLto
URLto = "mailto:" & maill
ActiveWorkbook.FollowHyperlink Address:=URLto
End Sub
 
Private Sub UserForm_activate()
Dim ob As Control
For Each ob In Me.Controls
If ob.Tag > "" Then
Select Case Val(ob.Tag)
Case 16, 17
ob = Format(Feuil9.Cells(gg, Val(ob.Tag)), "0.00")
ob = Replace(ob, ",", ".")
Case Else
ob = Feuil9.Cells(gg, Val(ob.Tag))
End Select
End If
Next
If nom = "" Then nom = WorksheetFunction.Max(Feuil9.Range("a:a")) + 1
clien.Label58.Caption = dep.Label87
If Label58 = "Nouveau" Then TextBox18 = Format(Date, "dd/mm/yyyy")
If Label58 = "Nouveau" Then CheckBox1.Value = Feuil11.Range("G9")
End Sub
 
Private Sub UserForm_Initialize()
Dim aa
plus
aa = Feuil18.Range("a2:a" & Feuil18.Range("a6500").End(xlUp).Row)
ComboBox1.List = aa
aa = Feuil18.Range("b2:b" & Feuil18.Range("b6500").End(xlUp).Row)
ComboBox2.List = aa
aa = Feuil18.Range("c2:c" & Feuil18.Range("c6500").End(xlUp).Row)
ComboBox3.List = aa
aa = Feuil18.Range("e2:e" & Feuil18.Range("e6500").End(xlUp).Row)
ComboBox5.List = aa
aa = Feuil18.Range("g2:g" & Feuil18.Range("g6500").End(xlUp).Row)
ComboBox6.List = aa
aa = Feuil18.Range("h2:h" & Feuil18.Range("h6500").End(xlUp).Row)
ComboBox7.List = aa
aa = Feuil18.Range("i2:i" & Feuil18.Range("i6500").End(xlUp).Row)
ComboBox8.List = aa
aa = Feuil18.Range("f2:f" & Feuil18.Range("f6500").End(xlUp).Row)
ComboBox9.List = aa
aa = Feuil18.Range("k2:k" & Feuil18.Range("k6500").End(xlUp).Row)
ComboBox10.List = aa
aa = Feuil18.Range("j2:j" & Feuil18.Range("j6500").End(xlUp).Row)
ComboBox11.List = aa
 
TextBox6.MaxLength = 11 'Assistance
TextBox6.AutoTab = True
TextBox2.AutoTab = True
TextBox3.AutoTab = True
tel.AutoTab = True
TextBox12.AutoTab = True
TextBox7.AutoTab = True
TextBox8.AutoTab = True
 
Me.cp.Visible = False
Label3.Visible = False
Me.ComboBox8.Visible = False
Label44.Visible = False
Me.tel.Visible = False
Label38.Visible = False
Me.ComboBox4.Visible = False 'Détail connaissance
Label26.Visible = False
Me.maill.Visible = False
Label27.Visible = False
End Sub
 
Sub controleLastName_contactsOutlook()
    Dim olApp As New Outlook.Application
    Dim Cible As Outlook.ContactItem
    Dim dossierContacts As Outlook.MAPIFolder
    Dim leNom As String
    Dim leTel As String
 
    leNom = adr.Value
    leTel = TextBox2.Value
 
    Set olApp = New Outlook.Application
    Set dossierContacts = olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts)
 
    Set Cible = dossierContacts.Items.Find("?[FullName] = '" & leNom & "' And [HomeTelephoneNumber] = '" & leTel & "'") '(lastName)
    If Not Cible Is Nothing Then
        MsgBox "Le contact existe déjà dans Ms Outlook"
    Else
        MsgBox "Le contact n'existe pas et donc va être ajouter"
        ajouterContactOutlook
    End If
End Sub
 
Sub ajouterContactOutlook()
    Dim objOutlook As Outlook.Application
    Dim objContact As ContactItem
 
    Set objOutlook = New Outlook.Application
    Set objContact = objOutlook.CreateItem(olContactItem)
 
    With objContact
        .Email1Address = TextBox4.Text
        .LastName = adr.Text
        .CompanyName = cp.Text
        .HomeTelephoneNumber = TextBox2.Text
        .MobileTelephoneNumber = TextBox3.Text
        .OtherTelephoneNumber = TextBox12.Text
        .HomeAddressStreet = pay.Text
        .HomeAddressCity = ComboBox2.Value
        .Body = TextBox5.Text
        .Categories = ComboBox6.Value
        'Sauvegarde le contact
        .Save
    End With
End Sub
 
Private Sub VérifExistence()
 Dim TV() As Variant, L As Long
 TV = Feuil9.[C:D].Value
 L = 1
 Do: L = L + 1
    If TV(L, 1) = "" And TV(L, 2) = "" Then Exit Sub
    If TV(L, 1) = adr And TV(L, 2) = cp Then Exit Do
    Loop
 MsgBox adr & " " & cp & " existe déjà"
 End Sub

et pour Gestion (fenetre principale)

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
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
Option Explicit
 
Private Sub ac1_AfterUpdate()
callcul
End Sub
Private Sub ac2_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)
callcul
End Sub
 
Private Sub ac3_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)
callcul
End Sub
 
Private Sub CheckBox1_Click()
If CheckBox1 = True Then listclient.MultiSelect = fmMultiSelectExtended Else listclient.MultiSelect = fmMultiSelectSingle
End Sub
 
Private Sub CheckBox2_Click()
If CheckBox2 = True Then Feuil17.Cells(fact, 7) = 1 Else Feuil17.Cells(fact, 7) = ""
End Sub
 
Private Sub client_Click()
If fact = 0 Then Exit Sub
gg = dep.client '.List(client.ListIndex, 1)
End Sub
 
Private Sub client_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
gg = dep.client.List(client.ListIndex, 1)
If gg = 0 Then Exit Sub
clien.Show
End Sub
 
Private Sub client_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal XX As Single, ByVal Y As Single)
Dim a
If Button = 2 Then
If fact = 10000 Then Exit Sub
If gg = 0 Then Exit Sub
If nom <> "" Then a = MsgBox(mess(9), vbYesNo): If a = 7 Then Exit Sub
pamodif = False
no = Feuil9.Cells(gg, 1)
civi = Feuil9.Cells(gg, 2)
nom = Feuil9.Cells(gg, 3)
attention = Feuil9.Cells(gg, 4)
adr = Feuil9.Cells(gg, 8)
cp = Feuil9.Cells(gg, 9)
If Feuil9.Cells(gg, 10) = "" Then tel = Feuil9.Cells(gg, 11) Else tel = Feuil9.Cells(gg, 10)
maill = Feuil9.Cells(gg, 13)
pay = Feuil9.Cells(gg, 6)
notva = Feuil9.Cells(gg, 7)
TextBox3 = Feuil9.Cells(gg, 15)
TextBox7 = Feuil9.Cells(gg, 16)
TextBox8 = Feuil9.Cells(gg, 17)
ComboBox10 = Feuil9.Cells(gg, 33)
callcul
End If
End Sub
 
Private Sub ComboBox10_Change()
Feuil17.Cells(fact, 22) = ComboBox10
End Sub
 
Private Sub CommandButton1_Click()
Feuil3.Select
Application.Calculation = xlCalculationAutomatic
Feuil11.Range("G9") = "FAUX"
End
End Sub
 
Private Sub CommandButton10_Click()
nouvo = True
pamodif = False
fact = finf2 + 1: Feuil2.Cells(fact, 14) = Feuil11.Cells(13, 2): callcul: remet:   listclient.ListIndex = -1
If Feuil11.Range("g3") = True Then nodev = xintitule(1) Else nodev = ""
If Feuil11.Range("h3") = True Then NOFAC = xintitule(2) Else NOFAC = ""
End Sub
 
Private Sub CommandButton11_Click()
 pamodif = True
If gg = 0 Then Exit Sub
clien.Show
End Sub
 
Private Sub CommandButton12_Click()
Dim a
If fact = 10000 Then Exit Sub
If gg = 0 Then Exit Sub
If nom <> "" Then a = MsgBox(mess(9), vbYesNo): If a = 7 Then Exit Sub
pamodif = False
no = Feuil9.Cells(gg, 1)
civi = Feuil9.Cells(gg, 2)
nom = Feuil9.Cells(gg, 3)
attention = Feuil9.Cells(gg, 4)
adr = Feuil9.Cells(gg, 8)
cp = Feuil9.Cells(gg, 9)
'tel = Feuil9.Cells(gg, 10)
If Feuil9.Cells(gg, 10) = "" Then tel = Feuil9.Cells(gg, 11) Else tel = Feuil9.Cells(gg, 10)
maill = Feuil9.Cells(gg, 13)
pay = Feuil9.Cells(gg, 6)
notva = Feuil9.Cells(gg, 7)
TextBox3 = Feuil9.Cells(gg, 15)
TextBox7 = Feuil9.Cells(gg, 16)
TextBox8 = Feuil9.Cells(gg, 17)
ComboBox10 = Feuil9.Cells(gg, 33)
callcul
End Sub
 
Private Sub CommandButton13_Click()
Label87 = CommandButton13.Caption
Feuil11.Range("G9") = "VRAI"
CheckBox2 = True
pamodif = True
gg = finf9 + 1: clien.Show
End Sub
 
Private Sub CommandButton14_Click()
derfac = fact
UserForm3.Show
If Feuil10.Cells(2, 1) <> "" Then
dep.Hide
bilan.Show
fact = derfac
dep.Show
End If
End Sub
 
Private Sub CommandButton15_Click()
pamodif = True
UserForm2.Show
End Sub
 
Private Sub CommandButton2_Click()
If TextBox2 = "" Then NouveauRDV_Calendrier
Dim dTextBox As Date
Dim a, fd As Long, h As Integer
If nouvo = True Then pamodif = False
If fact = 10000 Then a = MsgBox(mess(4), vbYesNo, mess(22))
If a = 6 Then CommandButton10 = True: Exit Sub
If a = 7 Then Exit Sub
If nom = "" Then MsgBox mess(20): Exit Sub
dep.Hide
If nouvo = True Then
If Feuil9.Cells(gg, 21) = "Particulier" Then h = 0 Else h = 1
If dep.deplac = False Then
If Feuil9.Cells(gg, 16) > 0 Then fd = Fix(Feuil9.Cells(gg, 16) * Feuil1.Cells(1, h + 4) * 2): Feuil2.Cells(fact, 41) = "1|1||" & fd & "||" & Feuil11.Cells(14, 2) & "|"
End If
fd = Feuil1.Cells(21, h + 4): Feuil2.Cells(fact, 42) = "21|1||" & fd & "||" & Feuil11.Cells(14, 2) & "|"
If deplac = True Then TextBox8 = "": TextBox7 = ""
Feuil2.Cells(fact, 15) = -1
End If
dTextBox = TimeValue(Me.TextBox4.Text)
Me.TextBox2.Text = Format(dTextBox + TimeValue("1:00"), "hh:mm")
UserForm1.Show
nouvo = False
End Sub
 
Private Sub CommandButton24_Click()
Dim a
ufCal.Show
If retourdate = "" Then Exit Sub
datedevis = retourdate
If InStr(1, nodev, "-") > 0 Then a = Split(nodev, "-"): nodev = Val(a(1))
If retourdate > "" Then nodev = Year(retourdate) & Format(Month(retourdate), "00") & "-" & Format(nodev, "0000")
End Sub
 
Private Sub CommandButton25_Click()
Dim a
ufCal.Show
If retourdate = "" Then Exit Sub
datefac = retourdate
If InStr(1, NOFAC, "-") > 0 Then a = Split(NOFAC, "-"): NOFAC = Val(a(1))
If retourdate > "" Then NOFAC = Year(retourdate) & Format(Month(retourdate), "00") & "-" & Format(NOFAC, "0000")
If TextBox10 = "" Then TextBox10 = datefac Else TextBox10 = ""
End Sub
 
Private Sub CommandButton26_Click()
If fact = 10000 Then Exit Sub
donne
dep.Hide
page1.PrintPreview
dep.Show
Feuil3.Select
End Sub
 
Private Sub CommandButton27_Click()
If fact = 10000 Then Exit Sub
donne
page1.PrintOut From:=1, To:=retour
End Sub
 
Private Sub CommandButton28_Click()
If fact = 10000 Then Exit Sub
donne
page2.PrintOut From:=1, To:=retour
End Sub
 
Private Sub CommandButton29_Click()
If fact = 10000 Then Exit Sub
donne
dep.Hide
page2.PrintPreview
dep.Show
Feuil3.Select
End Sub
 
Private Sub CommandButton30_Click()
If fact = 10000 Then Exit Sub
donne
page3.PrintOut From:=1, To:=retour
End Sub
 
Private Sub CommandButton31_Click()
If fact = 10000 Then Exit Sub
donne
dep.Hide
page3.PrintPreview
dep.Show
Feuil3.Select
End Sub
 
Private Sub CommandButton33_Click()
Dim r As Integer
listclient.Clear: etafac2.ListIndex = -1
If client.ListIndex = -1 Then MsgBox (mess(1)): Exit Sub
condi = Feuil9.Cells(client.ListIndex + 2, 1)
: Y = 0
If Crois = False Then
For r = finf2 To 2 Step -1
If Feuil2.Cells(r, 1) = condi Then
listclient.AddItem Feuil2.Cells(r, 3)
listclient.List(Y, 1) = r
Y = Y + 1
End If
Next
Else
For r = 2 To finf2
If Feuil2.Cells(r, 1) = condi Then
listclient.AddItem Feuil2.Cells(r, 3)
listclient.List(Y, 1) = r
Y = Y + 1
End If
Next
End If
factt.Max = listclient.ListCount
If factt.Max > 0 Then fact = Val((listclient.List(0, 1))) Else fact = 10000
If factt.Max > 0 Then listclient.ListIndex = 0 Else listclient.ListIndex = -1
callcul
remet
End Sub
 
Private Sub CommandButton35_Click()
If fact = 10000 Then Exit Sub
Dim a
If paiement > "" Then Exit Sub
a = MsgBox(mess(2), vbYesNo)
If a = 7 Then Exit Sub
Feuil2.Rows(fact).Delete
lisfact
End Sub
 
Private Sub CommandButton36_Click()
callcul
pamodif = True
resum.Show
End Sub
 
Private Sub CommandButton37_Click()
derfac = fact
UserForm33.Show
If Feuil13.Cells(2, 1) <> "" Then UserForm4.Show
fact = derfac
End Sub
 
Private Sub CommandButton38_Click()
Application.Dialogs(xlDialogPrinterSetup).Show
End Sub
 
Private Sub CommandButton39_Click()
ThisWorkbook.Save
End Sub
 
Private Sub CommandButton4_Click()
If fact = 10000 Then Exit Sub
imprim
dep.Hide
Feuil4.PrintPreview
dep.Show
Feuil3.Select
End Sub
 
Private Sub CommandButton40_Click()
Dim r As Integer
 Feuil9.Range("a1:al" & finf9).Sort Key1:=Feuil9.Range("c1"), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
dico1
dep.client.Clear
For r = 2 To finf9
dep.client.AddItem Feuil9.Cells(r, 1) & " " & Feuil9.Cells(r, 3) & " (" & Feuil9.Cells(r, 4) & ")"
dep.client.List(r - 2, 1) = r
Next
End Sub
 
Private Sub CommandButton41_Click()
ufCal.Show
If retourdate <> "" Then TextBox1 = retourdate
End Sub
 
Private Sub CommandButton43_Click()
Dim a
ufCal.Show
If retourdate = "" Then Exit Sub
TextBox10 = retourdate
End Sub
 
Private Sub CommandButton42_Click()
TextBox9 = ""
End Sub
 
Private Sub CommandButton44_Click()
Dim NomFichier As String
Dim TypeDoc As String
Dim AbreTypeDoc As String
Dim Numdoc As String
Dim DateDoc As String
Dim HreDoc As String
Dim NomCli As String
Dim TelEnt As String
Dim PortEnt As String
Dim MailCli As String
Dim MailEnt As String
Dim AdressEnt As String
Dim VilleEnt As String
Dim MontantTTC As String
Dim objMessage As Object
Dim messageHTML As String
Dim sNomPdf As String
Dim sDossier As String
Dim sNomCrypt As String
Dim iMsg As Object
Dim iConf As Object
Dim serveurSMTP As String
 
    sDossier = ThisWorkbook.Path
 
    TypeDoc = Worksheets("Document").Range("F25").Value
    AbreTypeDoc = Worksheets("Document").Range("G26").Value
    Numdoc = Worksheets("Document").Range("H26").Value
    DateDoc = Worksheets("Document").Range("G27")
    HreDoc = Hour(Time) & "-" & Minute(Time)
    NomCli = Worksheets("Document").Range("F31").Value
    TelEnt = Worksheets("Document").Range("B32").Value
    PortEnt = Worksheets("Document").Range("B33").Value
    MailEnt = Worksheets("Document").Range("O36").Value
    AdressEnt = Worksheets("Document").Range("B30").Value
    VilleEnt = Worksheets("Document").Range("B31").Value
    MailCli = Worksheets("Document").Range("F35").Value
    MontantTTC = Worksheets("Document").Range("N45").Value
    serveurSMTP = Worksheets("invi").Range("Y2").Value
    NomFichier = AbreTypeDoc & " " & Numdoc & " du " & DateDoc
 
If fact = 10000 Then Exit Sub
imprim
 
    On Error GoTo errorHandler
    sNomPdf = sDossier & "\" & NomFichier & ".pdf"
 
    Worksheets("Document").ExportAsFixedFormat _
            Type:=xlTypePDF, _
            Filename:=sNomPdf, _
            Quality:=xlQualityStandard, _
            IncludeDocProperties:=True, _
            IgnorePrintAreas:=False, _
            OpenAfterPublish:=False
 
    sNomCrypt = sDossier & "\" & "Tempo.pdf"
    EncryptPDFUsingPdfforgeDll sNomPdf, sNomCrypt
 
    Kill sNomPdf
    Name sNomCrypt As sNomPdf
 
    Set objMessage = CreateObject("CDO.Message")
    objMessage.Subject = "votre " & TypeDoc & " n° " & AbreTypeDoc & " " & Numdoc & " du " & DateDoc
    objMessage.From = MailEnt
    objMessage.To = MailCli
 
If Feuil4.Cells(25, 6) = "Proposition commerciale" Then
  objMessage.TextBody = "Bonjour," & vbCrLf & vbCrLf & "Veuillez trouver ci-joint notre proposition commerciale..." & vbCrLf & vbCrLf & "Vous souhaitant bonne reception, nous restons a votre disposition pour tous renseignements." & vbCrLf & vbCrLf & "La lecture du fichier joint necessite la presence sur votre ordinateur du logiciel Adobe Acrobat Reader." & vbCrLf & "Si vous ne possedez pas ce logiciel cliquez sur : www.adobe.fr/products/acrobat/readstep.html pour le telecharger." & vbCrLf & vbCrLf & "Sinceres salutations." & vbCrLf & vbCrLf & "S. LESCARBOTTE, MaintenancePC" & vbCrLf & TelEnt & vbCrLf & PortEnt
ElseIf Feuil4.Cells(25, 6) = "Proposition commerciale acceptée" Then
  objMessage.TextBody = "Bonjour," & vbCrLf & vbCrLf & "Veuillez trouver ci-joint votre proposition commerciale acceptee..." & vbCrLf & vbCrLf & "Vous souhaitant bonne reception, nous restons a votre disposition pour tous renseignements." & vbCrLf & vbCrLf & "La lecture du fichier joint necessite la présence sur votre ordinateur du logiciel Adobe Acrobat Reader." & vbCrLf & "Si vous ne possedez pas ce logiciel cliquez sur : www.adobe.fr/products/acrobat/readstep.html pour le telecharger." & vbCrLf & vbCrLf & "Sinceres salutations." & vbCrLf & vbCrLf & "S. LESCARBOTTE, MaintenancePC" & vbCrLf & TelEnt & vbCrLf & PortEnt
ElseIf Feuil4.Cells(25, 6) = "Fiche d'intervention" Then
 objMessage.TextBody = "Bonjour," & vbCrLf & vbCrLf & "Veuillez trouver ci-joint la commande..." & vbCrLf & vbCrLf & "Vous souhaitant bonne reception, nous restons a votre disposition pour tous renseignements." & vbCrLf & vbCrLf & "La lecture du fichier joint necessite la presence sur votre ordinateur du logiciel Adobe Acrobat Reader." & vbCrLf & "Si vous ne possedez pas ce logiciel cliquez sur : www.adobe.fr/products/acrobat/readstep.html pour le telecharger." & vbCrLf & vbCrLf & "Sinceres salutations." & vbCrLf & vbCrLf & "S. LESCARBOTTE, MaintenancePC" & vbCrLf & TelEnt & vbCrLf & PortEnt
ElseIf Feuil4.Cells(25, 6) = "Facture" Then
 objMessage.TextBody = "Bonjour," & vbCrLf & vbCrLf & "Veuillez trouver ci-joint la copie de la facture acquittee, citee en objet, d'un montant de " & MontantTTC & " euros." & vbCrLf & vbCrLf & "Vous souhaitant bonne reception, nous restons a votre disposition pour tous renseignements." & vbCrLf & vbCrLf & "La lecture du fichier joint nécessite la presence sur votre ordinateur du logiciel Adobe Acrobat Reader." & vbCrLf & "Si vous ne possedez pas ce logiciel cliquez sur : www.adobe.fr/products/acrobat/readstep.html pour le telecharger." & vbCrLf & vbCrLf & "Sinceres salutations." & vbCrLf & vbCrLf & "S. LESCARBOTTE, MaintenancePC" & vbCrLf & TelEnt & vbCrLf & PortEnt
ElseIf Feuil4.Cells(25, 6) = "Facture à régler" Then
 objMessage.TextBody = "Bonjour," & vbCrLf & vbCrLf & "Veuillez trouver ci-joint la copie de la facture non acquittee, citee en objet, d'un montant de " & MontantTTC & " euros." & vbCrLf & "Le paiement est a adresse :" & vbCrLf & "     " & AdressEnt & vbCrLf & "     " & VilleEnt & vbCrLf & vbCrLf & "et libellé à M. LESCARBOTTE uniquement (sans autre information)" & vbCrLf & vbCrLf & "Vous souhaitant bonne réception, nous restons a votre disposition pour tous renseignements." & vbCrLf & vbCrLf & "La lecture du fichier joint necessite la présence sur votre ordinateur du logiciel Adobe Acrobat Reader." & vbCrLf & "Si vous ne posseedez pas ce logiciel cliquez sur : www.adobe.fr/products/acrobat/readstep.html pour le telecharger." & vbCrLf & vbCrLf & "Sinceres salutations." & vbCrLf & vbCrLf & "S. LESCARBOTTE, MaintenancePC" & vbCrLf & TelEnt & vbCrLf & PortEnt
'ElseIf Feuil4.Cells(25, 6) = "Avoir" Then
' objMessage.TextBody = "Bonjour," & vbCrLf & vbCrLf & "Veuillez trouver ci-joint votre avoir qui sera deduite sur la prochaine facture..." & vbCrLf & vbCrLf & "Vous souhaitant bonne reception, nous restons à votre disposition pour tous renseignements." & vbCrLf & vbCrLf & "La lecture du fichier joint necessite la presence sur votre ordinateur du logiciel Adobe Acrobat Reader." & vbCrLf & "Si vous ne possedez pas ce logiciel cliquez sur : www.adobe.fr/products/acrobat/readstep.html pour le télécharger." & vbCrLf & vbCrLf & "Sinceres salutations." & vbCrLf & vbCrLf & "S. LESCARBOTTE, MaintenancePC" & vbCrLf & TelEnt & vbCrLf & PortEnt
End If
    messageHTML = "Ceci est un message en HTML"
 
    objMessage.Configuration.Fields.Item _
            ("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
    objMessage.Configuration.Fields.Item _
            ("http://schemas.microsoft.com/cdo/configuration/smtpserver") = serveurSMTP
    objMessage.Configuration.Fields.Item _
            ("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
    objMessage.Configuration.Fields.Update
 
    objMessage.AddAttachment sNomPdf
    objMessage.Send
    objMessage.MDNRequested = True
 
    Set objMessage = Nothing
'    MsgBox "Le mail a été bien envoyé au client !"
UserForm5.Show
    Exit Sub
 
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
 
With iMsg
 Set .Configuration = iConf
 .Fields("urn:schemas:mailheader:disposition-notification-to") = MailEnt
 .Fields("urn:schemas:mailheader:return-receipt-to") = MailEnt
 .Fields.Update
 .Send
 End With
 
errorHandler:
    MsgBox Err.Description
        Feuil17.Cells(fact, 27) = "Oui" 'Ecrire Oui quand un clic est effectué
End Sub
 
Private Sub EncryptPDFUsingPdfforgeDll(sNomFichier As String, sOutputCrypt As String)
Dim Pdf As Object, Crypt As Object
 
    Set Crypt = CreateObject("pdfforge.pdf.PDFEncryptor")
 
    With Crypt
        .AllowAssembly = False
        .AllowCopy = False
        .AllowFillIn = False
        .AllowModifyAnnotations = False
        .AllowModifyContents = False
        .AllowPrinting = True
        .AllowPrintingHighResolution = True
        .AllowScreenReaders = False
        .EncryptionMethod = 2
 
        .OwnerPassword = "master"
        .UserPassword = ""
    End With
 
    Set Pdf = CreateObject("pdfforge.pdf.pdf")
    Pdf.EncryptPDFFile sNomFichier, sOutputCrypt, Crypt
 
    Set Pdf = Nothing
    Set Crypt = Nothing
End Sub
 
Private Sub CommandButton5_Click() 'Imprim document
Dim j As Integer
For j = 0 To listclient.ListCount - 1
If listclient.Selected(j) = True Then
fact = Val((listclient.List(j, 1))): factt = j + 1: nfac = fact - 1
 imprim
Feuil4.PrintOut From:=1, To:=retour
End If
Next
End Sub
 
Private Sub CommandButton6_Click()
If fact = 10000 Then Exit Sub
imprimfacture
dep.Hide
Feuil6.PrintPreview
dep.Show
Feuil3.Select
End Sub
 
Private Sub CommandButton7_Click()
Dim j As Integer
For j = 0 To listclient.ListCount - 1
If listclient.Selected(j) = True Then
fact = Val((listclient.List(j, 1))): factt = j + 1: nfac = fact - 1
imprimfacture
Feuil6.PrintOut From:=1, To:=retour
End If
Next
End Sub
 
Private Sub CommandButton8_Click()
If fact = 10000 Then Exit Sub
donne
dep.Hide
Feuil7.PrintPreview
dep.Show
Feuil3.Select
End Sub
 
Private Sub CommandButton9_Click()
If fact = 10000 Then Exit Sub
donne
Feuil7.PrintOut
End Sub
 
Private Sub Crois_Click()
lisfact
End Sub
 
Private Sub etafac2_Click()
condi = etafac2.ListIndex
lisfact
End Sub
 
Private Sub etatfac_Click()
Dim Flg As Boolean 'MPC
If fact = 10000 Or fact = 1 Then Exit Sub
Feuil2.Cells(fact, 14) = etatfac.ListIndex
 
Flg = etatfac.Value <> "ANNULE" And etatfac.Value <> "DEVIS" And etatfac.Value <> "AVOIR"
paiement.Enabled = Flg
CommandButton43.Visible = Flg
TextBox10.Enabled = Flg
 
End Sub
 
Private Sub factt_Change()
If fact = 10000 Then Exit Sub
If listclient.ListCount > 1 Then listclient.ListIndex = factt - 1 Else listclient.ListIndex = -1
If factt = 0 Then fact = 10000
callcul
remet
End Sub
 
Private Sub listclient_Change()
If listclient.ListIndex > -1 Then fact = Val((listclient.List((listclient.ListIndex), 1))): factt = listclient.ListIndex + 1: nfac = fact - 1
End Sub
 
Private Sub listclient_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
If fact = 10000 Then Exit Sub
dep.Hide
UserForm1.Show
End Sub
 
Private Sub OptionButton1_Click()
lisfact
End Sub
 
Private Sub OptionButton2_Click()
lisfact
End Sub
 
Private Sub OptionButton3_Click()
lisfact
End Sub
 
Private Sub paiement_Change()
If fact = 10000 Or fact = 1 Then Exit Sub
Feuil2.Cells(fact, 15) = paiement.ListIndex
If paiement = "" Then CommandButton35.Enabled = True Else CommandButton35.Enabled = False
End Sub
 
Private Sub paiement_Click()
If fact = 10000 Or fact = 1 Then Exit Sub
Feuil2.Cells(fact, 15) = paiement.ListIndex
End Sub
 
Private Sub TextBox10_Change()
If TextBox10 = "" Then CommandButton35.Enabled = True Else CommandButton35.Enabled = False
End Sub
 
Private Sub TextBox2_Change()
TextBox2.MaxLength = 5
If Len(TextBox2) = 2 Then TextBox2 = TextBox2 & ":"
End Sub
 
 
Private Sub TextBox4_Change()
TextBox4.MaxLength = 5
If Len(TextBox4) = 2 Then TextBox4 = TextBox4 & ":"
End Sub
 
Private Sub TextBox9_Change()
Dim r As Long, Y As Long
client.Clear
If TextBox9 = "" Then
For r = 2 To finf9
dep.client.AddItem Feuil9.Cells(r, 1) & " " & Feuil9.Cells(r, 3) & " (" & Feuil9.Cells(r, 4) & ")"
dep.client.List(r - 2, 1) = r
Next
Else
For r = 2 To finf9
If UCase(Mid(Feuil9.Cells(r, 3), 1, Len(TextBox9))) = UCase(TextBox9) Then
dep.client.AddItem Feuil9.Cells(r, 1) & " " & Feuil9.Cells(r, 3) & " (" & Feuil9.Cells(r, 4) & ")"
dep.client.List(Y, 1) = r
Y = Y + 1
End If
Next
End If
End Sub
 
Private Sub UserForm_Activate()
callcul
remet
If pamodif = True Then Exit Sub
lisfact
pamodif = True
End Sub
 
Private Sub UserForm_Initialize()
Dim aa
Application.DisplayAlerts = True
Application.Calculation = xlCalculationManual
moyen = Me.Height / (Application.Height - 20)
plus
messag
Set lecli = CreateObject("Scripting.Dictionary")
dico1
If Feuil3.Range("a1") = 1 Then Message
Dim r, ob As Object
Dim Cl As Classe1
fact = 2
pamodif = False
paiement.AddItem mess(16)
paiement.AddItem mess(17)
paiement.AddItem mess(18)
paiement.AddItem mess(19)
paiement.AddItem
etatfac.AddItem mess(24)
etatfac.AddItem mess(11)
etatfac.AddItem mess(25)
etatfac.AddItem mess(12)
etatfac.AddItem mess(13)
etatfac.AddItem mess(15)
etatfac.AddItem mess(14)
etatfac.AddItem mess(26)
etafac2.AddItem mess(21)
etafac2.AddItem mess(24)
etafac2.AddItem mess(11)
etafac2.AddItem mess(25)
etafac2.AddItem mess(12)
etafac2.AddItem mess(13)
etafac2.AddItem mess(15)
etafac2.AddItem mess(14)
etafac2.AddItem mess(26)
etafac2.ListIndex = 0
aa = Feuil18.Range("k2:k" & Feuil18.Range("k6500").End(xlUp).Row)
ComboBox10.List = aa
For r = 2 To finf9
dep.client.AddItem Feuil9.Cells(r, 1) & " " & Feuil9.Cells(r, 3) & " (" & Feuil9.Cells(r, 4) & ")"
dep.client.List(r - 2, 1) = r
Next
latva(1) = Feuil11.Cells(10, 2)
latva(2) = Feuil11.Cells(11, 2)
latva(3) = Feuil11.Cells(12, 2)
 For Each ob In Me.Controls
 Set Cl = New Classe1
 If TypeOf ob Is MSForms.TextBox Then Set Cl.texb = ob: CollectBox.Add Cl
 Next
 Set Cl = Nothing
 
TextBox2.AutoTab = True
TextBox4.AutoTab = True
TextBox1.MaxLength = 10
TextBox1.AutoTab = True
TextBox10.MaxLength = 10
TextBox10.AutoTab = True
datedevis.MaxLength = 10
datedevis.AutoTab = True
ac1.AutoTab = True
ac2.AutoTab = True
ac3.AutoTab = True
datefac.MaxLength = 10
datefac.AutoTab = True
 
End Sub
 
Public Sub remet()
Dim ob As Control, g
numero = factt
If fact = 1 Then Exit Sub
If fact = 10000 Then numero = ""
For Each ob In dep.Controls
If ob.Tag > "" And ob.Tag <> "denis" And ob.Tag <> "non" Then
g = Split(ob.Tag, ",")
If Val(g(0)) > 0 Then
ob = Feuil2.Cells(fact, Val(g(0)))
Else
If UBound(g) > 0 Then ob = Feuil17.Cells(fact, Val(g(1)))
End If
End If
Next
total = Format(totalfourniture, "0.00")
total2 = Format(totalmo, "0.00")
tvaaa = Format(totvaa, "0.00")
Totalttc = Format(xttc, "0.00")
depl = Format(totaldeplace, "0.00")
If paiement <> "" Then du = "" Else du = Format(xttc - xacmpt, "0.00")
If Feuil2.Cells(fact, 15) <> "" Then paiement.ListIndex = Feuil2.Cells(fact, 15) Else paiement.ListIndex = -1
If Feuil2.Cells(fact, 14) <> "" Then etatfac.ListIndex = Feuil2.Cells(fact, 14) Else etatfac.ListIndex = Feuil11.Cells(13, 2)
End Sub
 
Public Sub lisfact()
If OptionButton1 = True Then condis = 3
If OptionButton2 = True Then condis = 2
If OptionButton3 = True Then condis = 1
listclient.Clear: Y = 0: nfac = ""
Select Case condi
Case 0
If Crois = False Then
For cli = finf2 To 2 Step -1
insc
Y = Y + 1
Next
Else
For cli = 2 To finf2
insc
Y = Y + 1
Next
End If
Case 1, 2, 3, 4, 5, 6, 7
If Crois = False Then
For cli = finf2 To 2 Step -1
If Feuil2.Cells(cli, 1) <> "" And Feuil2.Cells(cli, 14) = condi - 1 Then
insc
Y = Y + 1
End If
Next
Else
For cli = 2 To finf2
If Feuil2.Cells(cli, 1) <> "" And Feuil2.Cells(cli, 14) = condi - 1 Then
insc
Y = Y + 1
End If
Next
End If
End Select
factt.Max = listclient.ListCount
If factt.Max > 0 Then fact = 2 Else fact = 10000
If factt.Max > 0 Then listclient.ListIndex = 0 Else listclient.ListIndex = -1
callcul
remet
End Sub
 
Public Sub insc()
Select Case condis
Case 0, 1
listclient.AddItem Feuil2.Cells(cli, 3)
Case 2
listclient.AddItem Feuil2.Cells(cli, 9)
Case 3
listclient.AddItem Feuil2.Cells(cli, 11)
End Select
listclient.List(Y, 1) = cli
End Sub
 
Sub NouveauRDV_Calendrier()
Dim OkApp As New Outlook.Application
Dim Rdv As Outlook.AppointmentItem
 
Set Rdv = OkApp.CreateItem(olAppointmentItem)
 
With Rdv
    .MeetingStatus = olMeeting
    .Subject = nom.Value
    .Body = libel.Value
    If deplac = True Then .Location = "au bureau" Else .Location = "à domicile"
    .Start = TextBox1.Value & " " & TextBox4.Value ' Attention : format mois/jours/année
    .Duration = 60 'minutes
    .Categories = "Clients"
    .ReminderSet = True
    .ReminderMinutesBeforeStart = 60
    .ReminderPlaySound = True
    .Mileage = TextBox7.Value
    .BusyStatus = olOutOfOffice
    .Save
End With
 
Set OkApp = Nothing
End Sub

Tout ce passe bien même avec ce code, c'est au moment que je rajoute une textbox dans l'userform client que survient le probleme

Merci

Stephanie