Option Explicit
Dim bFlgExit As Boolean
Dim LocOldLength As Integer
Dim TbxDate() As New Classe1
Dim Tbx7() As New Classe1
'Convertir texte en chiffre dans la base de donnée
Function GetDataType(ByVal Text As String) As Variant
If IsNumeric(Text) Then
GetDataType = Val(Text)
Else
GetDataType = Text
End If
End Function
Function GetDataTypeDate(ByVal Text As String) As Variant
If Text Like "####-##-##" And IsDate(Text) Then
GetDataTypeDate = DateValue(Text)
Else
GetDataTypeDate = Text
End If
End Function
'date de naissance
Private Function DiffDateAMJ(DateDebut As Date, DateFin As Date) As String
Dim NbAns As Long, NbMois As Long, NbJours As Long
Dim Tmp As Date, sA As String, sM As String, sJ As String
Tmp = DateSerial(Year(DateFin), Month(DateDebut), Day(DateDebut))
NbAns = Year(DateFin) - Year(DateDebut) + (Tmp > DateFin)
NbMois = Month(DateFin) - Month(DateDebut) - (12 * (Tmp > DateFin))
NbJours = Day(DateFin) - Day(DateDebut) + 1
If NbJours < 0 Then
NbMois = NbMois - 1
NbJours = Day(DateSerial(Year(DateFin), Month(DateFin), 0)) + NbJours
End If
If NbAns = 0 Then sA = "" Else sA = NbAns & " ans "
If NbMois = 0 Then sM = "" Else sM = NbMois & "mois "
If NbJours = 0 Then sJ = "" Else sJ = NbJours & "jours"
DiffDateAMJ = Trim$(sA)
'DiffDateAMJ = Trim$(sA & sM & sJ) pour avoir ans mois jours
End Function
Private Sub Reg605_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If Reg605.SelStart = 0 Then KeyAscii = Asc(UCase(Chr(KeyAscii)))
End Sub
Private Sub Text_date3_AfterUpdate()
If IsDate(Me.Text_date3) Then
Controls.Item("Text_age").Text = DiffDateAMJ(Me.Text_date3, Date)
End If
End Sub
'Autoriser seulement chiffres et virgules
Private Sub OnlyNumbers()
If TypeName(Me.ActiveControl) = "TextBox" Then
With Me.ActiveControl
If Not IsNumeric(.Value) And .Value <> vbNullString Then
MsgBox "Chiffres et virgule seulement"
.Value = vbNullString
End If
End With
End If
End Sub
Private Sub OnlyNumbersframe4()
'Ensures only numbers are entered in the TextBoxes on the UserForm. This does not affect the TextBoxes on the MultiPage control
If TypeName(Me.Controls.Item("Frame4").ActiveControl) = "TextBox" Then
With Me.Controls.Item("Frame4").ActiveControl
If Not IsNumeric(.Value) And .Value <> vbNullString Then
MsgBox "Chiffres et virgule seulement"
.Value = vbNullString
End If
End With
End If
End Sub
Private Sub OnlyNumbersframe5()
'Ensures only numbers are entered in the TextBoxes on the UserForm. This does not affect the TextBoxes on the MultiPage control
If TypeName(Me.Controls.Item("Frame5").ActiveControl) = "TextBox" Then
With Me.Controls.Item("Frame5").ActiveControl
If Not IsNumeric(.Value) And .Value <> vbNullString Then
MsgBox "Chiffres et virgule seulement"
.Value = vbNullString
End If
End With
End If
End Sub
'facteur de risque âge
Private Sub Condition_7()
If ((Controls.Item("Reg6").Text = "Femme") And (Controls.Item("Reg7").Text = "Oui")) Or ((Controls.Item("Reg6").Text = "Femme") And (Controls.Item("Text_age").Text >= "55 ans") And ((Controls.Item("Reg7").Text = "Non") Or (Controls.Item("Reg7").Text = ""))) Then
Controls.Item("Reg169").Text = "Femme de plus de 55 ans ou ménopausée"
Controls.Item("Reg192").Text = "Femme de plus de 55 ans ou ménopausée"
Else
If (Controls.Item("Reg6").Text = "Homme") And (Controls.Item("Text_age").Text >= "45 ans") Then
Controls.Item("Reg169").Text = "Homme de plus de 45 ans"
Controls.Item("Reg192").Text = "Homme de plus de 45 ans"
Else
Controls.Item("Reg169").Text = ""
Controls.Item("Reg192").Text = ""
End If
End If
End Sub
'Changer couleur de fond et vérouiller choix ménopause
Private Sub Reg6_change()
If Controls.Item("Reg6").Text = "Homme" Then
Controls.Item("Reg7").BackColor = "&H8000000F"
Controls.Item("Reg7").Enabled = False
Controls.Item("Reg7").Text = ""
Else: Controls.Item("Reg7").BackColor = "&H80000005"
Controls.Item("Reg7").Enabled = True
End If
Call Condition_7
End Sub
Private Sub Reg7_change()
Call Condition_7
End Sub
Private Sub text_age_change()
Call Condition_7
End Sub
'Calcul IMC
'Taille (Reg157) (Reg180)
'Poids (Reg158) (Reg181)
'IMC (Text_imc_ini) (Text_imc_fin)
Private Sub Condition_5()
OnlyNumbersframe4
If (Controls.Item("Reg157").Text) = "" Or (Controls.Item("Reg158").Text) = "" Then
Controls.Item("Text_imc_ini").Text = ""
End If
If Controls.Item("Reg157").Value = 0 Then
Controls.Item("Reg157").Value = ""
End If
If Reg157 = "" Or Reg158 = "" Then Exit Sub
Controls.Item("Text_imc_ini").Value = ((Reg158) / (((Reg157) / 100) ^ 2))
Controls.Item("Text_imc_ini").Value = Format(Controls.Item("Text_imc_ini").Value, "##.##")
If (Controls.Item("Reg157").Text) = "" And (Controls.Item("Reg158").Text) = "" Then
Controls.Item("Text_imc_ini").Text = ""
End If
End Sub
Private Sub Reg157_afterupdate()
Call Condition_5
End Sub
Private Sub Reg158_afterupdate()
Call Condition_5
End Sub
Private Sub Text_imc_ini_Change()
If Controls.Item("Text_imc_ini").Value = "" Then
Controls.Item("Reg170").Text = ""
End If
If Len(Controls.Item("Text_imc_ini").Text) >= 2 Then
On Error Resume Next
Reg170 = Application.WorksheetFunction. _
VLookup(CLng(Controls.Item("Text_imc_ini").Text), Worksheets("lists.vba").Range("F2:g61"), 2, True)
End If
If Controls.Item("Text_imc_ini").Value <= "30" Then
Controls.Item("Reg170").Text = ""
End If
End Sub
Private Sub Condition_6()
OnlyNumbersframe5
If (Controls.Item("Reg180").Text) = "" Or (Controls.Item("Reg181").Text) = "" Then
Controls.Item("Text_imc_fin").Text = ""
End If
If Controls.Item("Reg180").Value = 0 Then
Controls.Item("Reg180").Value = ""
End If
If Reg180 = "" Or Reg181 = "" Then Exit Sub
Controls.Item("Text_imc_fin").Value = ((Reg181) / (((Reg180) / 100) ^ 2))
Controls.Item("Text_imc_fin").Value = Format(Controls.Item("Text_imc_fin").Value, "##.##")
If (Controls.Item("Reg180").Text) = "" And (Controls.Item("Reg181").Text) = "" Then
Controls.Item("Text_imc_fin").Text = ""
End If
End Sub
Private Sub Reg180_afterupdate()
Call Condition_6
End Sub
Private Sub Reg181_afterupdate()
Call Condition_6
End Sub
Private Sub Text_imc_fin_Change()
If Controls.Item("Text_imc_fin").Value = "" Then
Controls.Item("Reg193").Text = ""
End If
If Len(Controls.Item("Text_imc_fin").Text) >= 2 Then
On Error Resume Next
Controls.Item("Reg193").Text = Application.WorksheetFunction. _
VLookup(CLng(Controls.Item("Text_imc_fin").Text), Worksheets("lists.vba").Range("F2:g61"), 2, True)
End If
If Controls.Item("Text_imc_fin").Value <= "30" Then
Controls.Item("Reg193").Text = ""
End If
End Sub
'fin calcul IMC
'Tapis roulant vs ergomètre pré
Private Sub Reg205_Change()
Dim ind As Long
For ind = 212 To 213
Controls("Reg" & ind).Enabled = IIf(Controls.Item("Reg205").Text = "Tapis roulant", "true", "false")
Controls("Reg" & ind).BackColor = IIf(Controls.Item("Reg205").Text = "Tapis roulant", "&H80000005", "&H80000004")
Next ind
For ind = 214 To 215
Controls("Reg" & ind).Enabled = IIf(Controls.Item("Reg205").Text = "Tapis roulant", "false", "true")
Controls("Reg" & ind).BackColor = IIf(Controls.Item("Reg205").Text = "Tapis roulant", "&H80000004", "&H80000005")
Next ind
If Controls.Item("Reg205").Text = "Tapis roulant" Then
Controls.Item("Label114").Caption = "Pente"
Else
Controls.Item("Label114").Caption = "Watt"
End If
If Controls.Item("Reg205").Text = "" Then
Controls.Item("Label114").Caption = "Pente / Watt"
End If
End Sub
'Tapis roulant vs ergomètre post
Private Sub Reg350_Change()
Dim ind As Long
For ind = 357 To 358
Controls("Reg" & ind).Enabled = IIf(Controls.Item("Reg350").Text = "Tapis roulant", "false", "true")
Controls("Reg" & ind).BackColor = IIf(Controls.Item("Reg350").Text = "Tapis roulant", "&H80000004", "&H80000005")
Next ind
For ind = 359 To 360
Controls("Reg" & ind).Enabled = IIf(Controls.Item("Reg350").Text = "Tapis roulant", "true", "false")
Controls("Reg" & ind).BackColor = IIf(Controls.Item("Reg350").Text = "Tapis roulant", "&H80000005", "&H80000004")
Next ind
If Controls.Item("Reg350").Text = "Tapis roulant" Then
Controls.Item("Label323").Caption = "Pente"
Else
Controls.Item("Label323").Caption = "Watt"
End If
If Controls.Item("Reg350").Text = "" Then
Controls.Item("Label323").Caption = "Pente / Watt"
End If
End Sub
' Protocole adapté (vitesse et pente) ini
Private Sub Reg206_Change()
Dim ind As Long
For ind = 301 To 340
Controls("Reg" & ind).Enabled = Controls.Item("Reg206").Text = "Protocole adapté"
Controls("Reg" & ind).BackColor = IIf(Controls.Item("Reg206").Text = "Protocole adapté", "&H80000005", "&H80000004")
Next ind
End Sub
' Protocole adapté (vitesse et pente) fin
Private Sub Reg351_Change()
Dim ind As Long
For ind = 446 To 485
Controls("Reg" & ind).Enabled = Controls.Item("Reg351").Text = "Protocole adapté"
Controls("Reg" & ind).BackColor = IIf(Controls.Item("Reg351").Text = "Protocole adapté", "&H80000005", "&H80000004")
Next ind
End Sub
'Circuit d'activités physiques
Private Sub Reg493_Change()
Dim ind As Long
For ind = 494 To 495
Controls("Reg" & ind).Enabled = IIf(Controls.Item("Reg493").Text = "Oui", "True", "False")
Controls("Reg" & ind).BackColor = IIf(Controls.Item("Reg493").Text = "Oui", "&H80000005", "&H80000004")
Next ind
For ind = 498 To 502
Controls("Reg" & ind).Enabled = IIf(Controls.Item("Reg493").Text = "Oui", "True", "False")
Controls("Reg" & ind).BackColor = IIf(Controls.Item("Reg493").Text = "Oui", "&H80000005", "&H80000004")
Next ind
End Sub
Private Sub Reg512_Change()
Dim ind As Long
For ind = 513 To 514
Controls("Reg" & ind).Enabled = IIf(Controls.Item("Reg512").Text = "Oui", "True", "False")
Controls("Reg" & ind).BackColor = IIf(Controls.Item("Reg512").Text = "Oui", "&H80000005", "&H80000004")
Next ind
For ind = 517 To 521
Controls("Reg" & ind).Enabled = IIf(Controls.Item("Reg512").Text = "Oui", "True", "False")
Controls("Reg" & ind).BackColor = IIf(Controls.Item("Reg512").Text = "Oui", "&H80000005", "&H80000004")
Next ind
End Sub
'Équilibre unipodal > 45 sec
Private Sub Condition_1()
If Controls.Item("Reg549").Value >= "45" Or Controls.Item("Reg550").Value >= "45" Or Controls.Item("Reg551").Value >= "45" Then
Controls.Item("Reg552").Enabled = True
Controls.Item("Reg552").BackColor = "&H80000005"
Else
Controls.Item("Reg552").Enabled = False
Controls.Item("Reg552").BackColor = "&H80000004"
End If
End Sub
Private Sub Reg549_AfterUpdate()
Call Condition_1
End Sub
Private Sub Reg550_AfterUpdate()
Call Condition_1
End Sub
Private Sub Reg551_AfterUpdate()
Call Condition_1
End Sub
Private Sub Condition_2()
If Controls.Item("Reg553").Value >= "45" Or Controls.Item("Reg554").Value >= "45" Or Controls.Item("Reg555").Value >= "45" Then
Controls.Item("Reg556").Enabled = True
Controls.Item("Reg556").BackColor = "&H80000005"
Else
Controls.Item("Reg556").Enabled = False
Controls.Item("Reg556").BackColor = "&H80000004"
End If
End Sub
Private Sub Reg553_AfterUpdate()
Call Condition_2
End Sub
Private Sub Reg554_AfterUpdate()
Call Condition_2
End Sub
Private Sub Reg555_AfterUpdate()
Call Condition_2
End Sub
Private Sub Condition_3()
If Controls.Item("Reg586").Value >= "45" Or Controls.Item("Reg587").Value >= "45" Or Controls.Item("Reg588").Value >= "45" Then
Controls.Item("Reg589").Enabled = True
Controls.Item("Reg589").BackColor = "&H80000005"
Else
Controls.Item("Reg589").Enabled = False
Controls.Item("Reg589").BackColor = "&H80000004"
End If
End Sub
Private Sub Reg586_AfterUpdate()
Call Condition_3
End Sub
Private Sub Reg587_AfterUpdate()
Call Condition_3
End Sub
Private Sub Reg588_AfterUpdate()
Call Condition_3
End Sub
Private Sub Condition_4()
If Controls.Item("Reg590").Value >= "45" Or Controls.Item("Reg591").Value >= "45" Or Controls.Item("Reg592").Value >= "45" Then
Controls.Item("Reg593").Enabled = True
Controls.Item("Reg593").BackColor = "&H80000005"
Else
Controls.Item("Reg593").Enabled = False
Controls.Item("Reg593").BackColor = "&H80000004"
End If
End Sub
Private Sub Reg590_AfterUpdate()
Call Condition_4
End Sub
Private Sub Reg591_AfterUpdate()
Call Condition_4
End Sub
Private Sub Reg592_AfterUpdate()
Call Condition_4
End Sub
'fin Équilibre unipodal >45
'Dominance préhension
Private Sub Reg8_AfterUpdate()
Controls.Item("Reg541").Text = Controls.Item("Reg8").Text
Controls.Item("Reg578").Text = Controls.Item("Reg8").Text
End Sub
'convertir kg en livres
Private Sub Text_kg2_Change()
On Error Resume Next
OnlyNumbers
If Controls.Item("Text_kg2").Text = "" Then
Controls.Item("Text_livres2").Text = ""
Else
Controls.Item("Text_livres2").Text = (Text_kg2 * 2.2)
Controls.Item("Text_livres2").Value = Format(Controls.Item("Text_livres2").Value, "###.##")
End If
End Sub
'convertir livres en kg
Private Sub Text_livres1_Change()
On Error Resume Next
OnlyNumbers
If Controls.Item("Text_livres1").Value = "" Then
Controls.Item("Text_kg1").Text = ""
Else
Controls.Item("Text_kg1").Text = (Text_livres1 / 2.2)
Controls.Item("Text_kg1").Value = Format(Controls.Item("Text_kg1").Value, "###.##")
End If
End Sub
'convertir cm en pouces
Private Sub Text_cm_Change()
OnlyNumbers
If Controls.Item("Text_cm").Text = "" Then
Controls.Item("Text_pouces").Text = ""
Else
Controls.Item("Text_pouces").Text = (Text_cm / 2.54)
Controls.Item("Text_pouces").Value = Format(Controls.Item("Text_pouces").Value, "##.#")
End If
End Sub
[B]' When we click the 'continue' button
Private Sub CommandButton1_Click()
Dim Sht As Worksheet, cStart As Range
Dim LasteRow As Long
Dim TargetRow As Long 'variable for position control
Dim FullName As String 'full name
Dim UserMessage As String 'variable to configure user message at the end
Dim ind As Long
Dim Dossier As String
' Désactiver les évènements et le calcul auto
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'
Dossier = Reg5
FullName = Reg4 & " " & Reg3 'concatenate first and surname for use in code below
' Define the work sheet
Set Sht = ThisWorkbook.Sheets("Data")
Set cStart = Sht.Range("Data_Start")
' The last row
LasteRow = Sht.ListObjects("Tableau1").ListRows.Count
'begin check if in 'edit' or 'add new' mode
If Sheets("Engine").Range("B4").Value = "NEW" Then 'in 'new' mode
'begin validation check 'check if name already exists
If Application.WorksheetFunction.CountIf(Sht.Range("H8:d" & LasteRow), Dossier) > 0 Then
MsgBox "Le numéro de dossier existe déjà", 0, "Check"
Exit Sub 'notify user and exit the routine
End If
'end validation check
TargetRow = Sht.ListObjects("Tableau1").Range(LasteRow, 1).End(xlUp).Row - 7 + 1
UserMessage = " a été ajouté à la base de données" 'configure user message for add new entry
Else 'in 'edit' mode
TargetRow = Sheets("Engine").Range("B5").Value 'make variable equal to the value saved in the engine
UserMessage = " a été modifié" 'configure user message for edit entry
End If
'''BEGIN INPUT DATA INTO DATABASE'''
cStart.Offset(TargetRow, 0).Value = TargetRow 'ref
cStart.Offset(TargetRow, 1).Value = UCase(Reg4) & " " & Reg3 'Txt_First 'full name 'concatenate
For ind = 1 To 611
cStart.Offset(TargetRow, 2 + ind - 1).Value = GetDataType(Controls("Reg" & ind).Value)
Next ind
For ind = 1 To 23
cStart.Offset(TargetRow, 613 + ind - 1).Value = GetDataTypeDate(Controls("Text_date" & ind).Value)
Next ind
' Réactiver les évènements et le calcul auto
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
'''END INPUT DATA INTO DATABASE'''
Unload Data_UF 'close the userform
MsgBox FullName & UserMessage, 0, "Complété" 'display message box (configured according to mode)
End Sub
Private Sub CommandButton2_Click()
Unload Data_UF
End Sub
[/B]
' Utilisation d'un module de classe pour tous les controls contenant le terme "date"
Private Sub UserForm_Initialize()
Dim ctl As Control, ind As Long, Ind7 As Integer
ind = 0: Ind7 = 0
' Pour chaque control de l'UserForm
For Each ctl In Me.Controls
' Si son nom contient "date"
If InStr(1, ctl.name, "date", vbTextCompare) > 0 Or _
InStr(1, "Text_sign_ini,Text_sign_fin", ctl.name) > 0 Then
' Définir une classe pour ce control
' Saisie d'une date de 10 caractères
ind = ind + 1
ReDim Preserve TbxDate(1 To ind)
Set TbxDate(ind).TbxDate = ctl
End If
' 2 control avec saisi d'une date de 7 caractères
If InStr(1, "Reg210,Reg356,", ctl.name & ",") > 0 Then 'possible d'ajouter vbTextCompare
Ind7 = Ind7 + 1
ReDim Preserve Tbx7(1 To Ind7)
Set Tbx7(Ind7).Tbx7 = ctl
End If
Next ctl
End Sub