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
| Option Explicit
' Déclaration des variables et constantes de portées module
Private Enum Status ' Constantes énumérées Status
Consultation = 0: Modify = 1: NewRec = 2: Remove = 3
End Enum
Const StatusLabel As String = "Consultation;Modification;Création;Suppression"
Const appTitle As String = "SUIVI QUALITE - Fiche de Non-Conformité"
Const appVersion As Double = 1#
Dim bouton_Choix As Variant
Dim I As Byte
Dim MyCategorie As String
Dim MyType As String
Dim MySelection As String
Dim num As Integer
Dim NumFiche As Variant
Dim UserFormStatus As Byte ' Statut du type de travail (Consultation, Modify, NewRec, Remove)
Dim CurrentRecord As Long ' Enregistrement en cours
Dim rng As Range ' Plage de données traitée par le formulaire
Dim lstStatusText() As String
Private Sub txtFirstName_Change()
' Me.txtFirstName = UCase(Me.txtFirstName)
End Sub
Private Sub UserForm_Activate()
InitVariable ' Initialisation des variables
InitData ' Initialisation adresse liste des données + RowSource
InitComboBox ' Initialisation ComboBox
UserFormStatus = Status.Consultation ' Consultation par défaut
With Me ' Initialisation de certains contrôles
.cmdConfirm.Visible = False: .cmdCancel.Visible = False
.cboMember.Enabled = True: .frmMember.Enabled = False
usfTitle ' Titre du UserForm (Propriété Caption)
End With
' Focus sur le 1er enregistrement ou l'enregistrement sélectionné dans la feuille
With Me: .cboMember.ListIndex = Me.Tag: End With
End Sub
Private Sub InitVariable()
lstStatusText = Split(StatusLabel, ";")
With Me
.OptCLIENT.GroupName = "Choix": Me.OptFOURNI.GroupName = "Choix": Me.OptINTERNE.GroupName = "Choix"
If Len(.Tag) = 0 Then .Tag = 0
End With
End Sub
Private Sub InitComboBox()
With Me.cboMember
.ColumnHeads = True: .ColumnCount = 4: .ColumnWidths = "50;45;80;20"
End With
InitRowSource '
End Sub
Private Sub InitData()
' Redimensionnement de l'objet rng et RowSource
Set rng = Sheets("BDD").Range("A1").CurrentRegion
With rng
Set rng = .Offset(1).Resize(.Rows.Count - 1)
End With
End Sub
Private Sub InitRowSource()
With Me.cboMember
.RowSource = rng.Address(external:=True)
.ListIndex = 0 ' Force la sélection du premier enregistrement
End With
End Sub
Private Sub cboMember_Click()
CurrentRecord = Me.cboMember.ListIndex
ReadRecord CurrentRecord ' Lecture de l'enregistrement sélectionné
CheckButton
End Sub
Private Sub cmdCancel_Click()
ReadRecord CurrentRecord
OppositeStatus ' Inverse la valeur booléenne des boutons d'action
End Sub
Private Sub cmdConfirm_Click()
If Not IsFieldsFilled Then Exit Sub
Select Case UserFormStatus
Case Status.NewRec ' Nouvel enregistrement
WriteRecord rng.Rows.Count: InitData: InitRowSource
Me.cboMember.ListIndex = rng.Rows.Count - 1
Case Status.Modify: WriteRecord CurrentRecord ' Modification de l'enregistrement
End Select
'mSortTable2003.SortTable rng, "2"
OppositeStatus ' Inverse la valeur booléenne des boutons d'action
End Sub
Private Function IsFieldsFilled() As Boolean
' Ajouté le 22/4/2015 v 2.1
' Contrôle si tous les TextBox obligatoires sont remplis
Dim Ctrl As Control
IsFieldsFilled = True
For Each Ctrl In Me.Controls
If TypeOf Ctrl Is MSForms.TextBox Then
If LCase(Ctrl.Tag) = "fill" And Len(Trim(Ctrl.Value)) = 0 Then
Ctrl.SetFocus: IsFieldsFilled = False: Exit Function
End If
End If
Next Ctrl
End Function
Private Sub cmdExit_Click()
Unload Me ' Fermeture du UserForm
End Sub
Private Sub cmdModify_Click()
UserFormStatus = Status.Modify
OppositeStatus ' Inverse la valeur booléenne des boutons d'action
End Sub
Private Sub cmdNew_Click()
UserFormStatus = Status.NewRec
ClearTextBox ' Efface les valeurs des TextBox
OppositeStatus ' Inverse la valeur booléenne des boutons d'action
With Sheets("BDD")
NumFiche = .Range("A" & Rows.Count).End(xlUp).Row + 1
num = .Range("A" & Rows.Count).End(xlUp)
NumFiche = num + 1
End With
LblNum = NumFiche
LblNum = Format("FNC") & Format(NumFiche, "0000")
End Sub
Private Sub ClearTextBox()
' Efface toutes les valeurs contenues dans les contrôles TextBox du frame nommé frmMember
Dim Ctrl As Control
For Each Ctrl In Me.frmMember.Controls
If TypeOf Ctrl Is MSForms.TextBox Then Ctrl.Value = ""
Next
End Sub
Private Sub OptCLIENT_Click()
ListQUI.Clear
For I = 3 To Sheets("CLI-FOURNI-ART").Range("C65536").End(xlUp).Row
With ListQUI
.AddItem Sheets("CLI-FOURNI-ART").Range("C" & I)
End With
Next
MyCategorie = " Clients"
Me.ListQUI.ListIndex = 0
'MAJ libellé liste déroulante
With TypeReclamation
.LblQUI.Caption = "Liste des" & MyCategorie
End With
End Sub
Private Sub OptFOURNI_Click()
ListQUI.Clear
For I = 3 To Sheets("CLI-FOURNI-ART").Range("C65536").End(xlUp).Row
With ListQUI
.AddItem Sheets("CLI-FOURNI-ART").Range("F" & I)
End With
Next
MyCategorie = " Fournisseurs / Sous-Traitants"
Me.ListQUI.ListIndex = 0
'MAJ libellé liste déroulante
With TypeReclamation
.LblQUI.Caption = "Liste des" & MyCategorie
End With
End Sub
Private Sub OptINTERNE_Click()
ListQUI.Clear
For I = 3 To Sheets("CLI-FOURNI-ART").Range("C65536").End(xlUp).Row
With ListQUI
.AddItem Sheets("CLI-FOURNI-ART").Range("N" & I)
End With
Next
MyCategorie = " Services internes"
Me.ListQUI.ListIndex = 0
'MAJ libellé liste déroulante
With TypeReclamation
.LblQUI.Caption = "Liste des" & MyCategorie
End With
End Sub
Private Sub RemoveRecord(ByVal NumFiche As Long)
' Suppression de l'enregistrement
' Contrainte : il doit rester un enregistrement
Select Case True
Case rng.Rows.Count = 1 ' Reste 1 enregistrement
MsgBox "Vous devez laisser un enregistrement", vbInformation, "Suppression impossible"
Case MsgBox("Voulez-vous supprimer la ligne sélectionnée", _
vbCritical + vbYesNo + vbDefaultButton2, _
"Suppression de la ligne " & CurrentRecord + 1) = vbYes
NumFiche = NumFiche + 1
rng.Rows(NumFiche).Delete Shift:=xlUp ' Supprime la ligne de la plage
InitData ' Initialisation des variables objets
InitRowSource ' Initialisation de la propriété RowSource
CurrentRecord = 0: Me.cboMember.ListIndex = CurrentRecord
End Select
UserFormStatus = Status.Consultation
End Sub
Private Sub cmdNext_Click()
Me.cboMember.ListIndex = CurrentRecord + 1
End Sub
Private Sub cmdPrevious_Click()
Me.cboMember.ListIndex = CurrentRecord - 1
End Sub
Private Sub cmdFirst_Click()
Me.cboMember.ListIndex = 0
End Sub
Private Sub cmdLast_Click()
Me.cboMember.ListIndex = rng.Rows.Count - 1
End Sub
Private Sub cmdRemove_Click()
UserFormStatus = Status.Remove: usfTitle
RemoveRecord CurrentRecord ' Supprime l'enregistrement courant
UserFormStatus = Status.Consultation: usfTitle
End Sub
Private Sub ReadRecord(ByVal NumFiche As Long)
' Lecture de l'enregistrement
NumFiche = NumFiche + 1
With rng
Me.LblNum = .Cells(NumFiche, 1)
'Me.LblQUI = .Cells(NumFiche, 3)
Me.DTPDate = .Cells(NumFiche, 4)
If UCase(Sheets("BDD").Cells(NumFiche, 2)) = "CLIENT" Then
Me.OptCLIENT.Value = True
ElseIf UCase(Sheets("BDD").Cells(NumFiche, 2)) = "FOURNISSEUR / SST" Then
Me.OptFOURNI.Value = True
ElseIf UCase(Sheets("BDD").Cells(NumFiche, 2)) = "INTERNE" Then
Me.OptINTERNE.Value = True
End If
NumFiche = .Cells(NumFiche, 1)
LblNum = NumFiche
LblNum = Format("FNC") & Format(NumFiche, "0000")
Me.frmMember.Caption = "Fiche " & LblNum
End With
End Sub
Private Sub WriteRecord(ByVal NumFiche As Long)
' Ecriture de l'enregistrement
Me.cboMember.ListIndex = -1
NumFiche = NumFiche + 1
'Me.Hide
For Each bouton_Choix In Frame_Choix.Controls
If bouton_Choix.Value Then
MyType = bouton_Choix.Caption
End If
Next
MySelection = Me.ListQUI.List(ListQUI.ListIndex)
With rng
With .Cells(NumFiche, 1)
If Len(.Value) = 0 Then ' ID
.Value = Application.WorksheetFunction.Max(rng.Columns(1)) + 1
End If
LblNum = Format("FNC") & Format(NumFiche, "0000")
End With
.Cells(NumFiche, 2) = MyType
.Cells(NumFiche, 3) = MySelection
.Cells(NumFiche, 4) = DTPDate
End With
Me.cboMember.ListIndex = CurrentRecord
End Sub
Sub OppositeStatus()
' Inverse la valeur booléenne des boutons d'action
' Modifie la propriété Caption du UserForm
With Me
.cboMember.Enabled = Not .cboMember.Enabled
.frmMember.Enabled = Not .frmMember.Enabled
.frmAction.Visible = Not .frmAction.Visible
.cmdCancel.Visible = Not .cmdCancel.Visible
.cmdConfirm.Visible = Not .cmdConfirm.Visible
.cmdExit.Visible = Not .cmdExit.Visible
.frmNavigation.Visible = Not .frmNavigation.Visible
If .cboMember.Enabled = True Then UserFormStatus = Status.Consultation ' Consultation
usfTitle ' Titre du UserForm
End With
End Sub
Private Function usfTitle()
' Modifie la propriété Caption du UserForm
Me.Caption = "(Ver " & appVersion & ") " & appTitle & " - " & lstStatusText(UserFormStatus)
End Function
Sub CheckButton()
With Me
.cmdFirst.Enabled = CurrentRecord > 0
.cmdPrevious.Enabled = CurrentRecord > 0
.cmdNext.Enabled = CurrentRecord <> rng.Rows.Count - 1
.cmdLast.Enabled = CurrentRecord <> rng.Rows.Count - 1
End With
End Sub
Private Sub UserForm_Terminate()
Set rng = Nothing
MsgBox "Bye, bye"
End Sub |
