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
| Option Explicit
Private Sub Form_Load()
'création (si nécessaire), dimensionnement, positionnement configuration des contrôles sur le formulaire
Label1(0).Move 120, 120, 1860, 195
Label1(0).Font = "MS Sans Serif"
Label1(0).FontBold = True
Label1(0).ForeColor = &H0&
Label1(0).Caption = "Exemple à sélectionner"
Load Label1(1) ' création, ajout d'un contrôle
Label1(1).Move 120, 1560, 1650, 195
Label1(1).Font = "MS Sans Serif"
Label1(1).FontBold = True
Label1(1).ForeColor = &H0&
Label1(1).Caption = "Votre propre entrée"
Load Label1(2)
Label1(2).Move 120, 2640, 4005, 195
Label1(2).Font = "MS Sans Serif"
Label1(2).FontBold = True
Label1(2).ForeColor = &HC00000
Label1(2).Caption = "Valeur retournée par la fonction RecupNumeric"
Label1(2).Visible = True
Load Label1(3)
Label1(3).Move 120, 3240, 3030, 195
Label1(3).Font = "MS Sans Serif"
Label1(3).FontBold = True
Label1(3).ForeColor = &HC00000
Label1(3).Caption = "Valeur retournée par la fonction Val"
Label1(3).Visible = True
Load Label1(4)
Label1(4).Move 120, 2250, 1200, 195
Label1(4).Font = "MS Sans Serif"
Label1(4).FontBold = True
Label1(4).ForeColor = &H0&
Label1(4).Caption = "Occurrence N°"
Label1(4).Visible = True
Load Label1(5)
Label1(5).Move 1380, 2250, 225, 195
Label1(5).Font = "MS Sans Serif"
Label1(5).FontBold = True
Label1(5).ForeColor = &H0&
Label1(5).Caption = "1"
Label1(5).Visible = True
Text1(0).Move 120, 1800, 3255, 315
Text1(0).Font = "MS Sans Serif"
Text1(0).ForeColor = &H0&
Text1(0).Text = "Essais de 16 exemples"
Load Text1(1)
Text1(1).Move 120, 2880, 4035, 315
Text1(1).Visible = True
Load Text1(2)
Text1(2).Move 120, 3480, 4035, 315
Text1(2).Visible = True
List1.Move 120, 420, 4035, 1035
List1.Font = "MS Sans Serif"
List1.ForeColor = &H0&
List1.Clear
List1.AddItem "Distance maximum: 12 mm"
List1.AddItem "Distance maximum: -12 mm"
List1.AddItem "Distance maximum: - 12 mm"
List1.AddItem "Distance maximum: 12,5 mm"
List1.AddItem "Distance maximum: 12.5 mm"
List1.AddItem "Distance maximum: .12.5, mm"
List1.AddItem "Distanse maximum: 0,12344.5, mm"
List1.AddItem "Distance maximum: 12 344,5 mm"
List1.AddItem "Distance maximum: 12 344.5 mm"
List1.AddItem "Distance maximum: 12.344.5 mm"
List1.AddItem "12 344.5 mm"
List1.AddItem " 12 344.5"
List1.AddItem "-12344.5"
List1.AddItem " - 12 - 3 --> 1° occurrence soit -12"
List1.AddItem "récupérer la 2° occurrence soit 3.52 (chiffre)"
List1.AddItem " juste un espace"
List1.AddItem "vide"
HScroll1.Move 1800, 2220, 2355, 255
HScroll1.Min = 1: HScroll1.Max = 10
HScroll1.Value = 1
Command1.Move 3480, 1800, 675, 315
Command1.Font = "MS Sans Serif"
Command1.Caption = "--> Go "
Command1_Click
Me.Caption = "Étude récupération numérique"
Me.Height = 4500: Me.Width = 4530
End Sub
Private Sub HScroll1_Change()
Label1(5).Caption = HScroll1.Value
End Sub
Private Sub HScroll1_Scroll()
HScroll1_Change
End Sub
Private Sub List1_Click()
Dim StrRecupe As String, XOccurrence As Integer
HScroll1.Value = 1
If List1.List(List1.ListIndex) = " juste un espace" Then
StrRecupe = " "
ElseIf List1.List(List1.ListIndex) = "vide" Then StrRecupe = ""
ElseIf List1.List(List1.ListIndex) = "récupérer la 2° occurrence soit 3.52 (chiffre)" Then
StrRecupe = List1.List(List1.ListIndex): HScroll1.Value = 2
Else
StrRecupe = List1.List(List1.ListIndex)
End If
Text1(0).BackColor = &HFFFFFF: List1.BackColor = &HC0FFC0
Text1(1).Text = RecupNumeric(StrRecupe, HScroll1.Value)
Text1(2).Text = Val(StrRecupe)
End Sub
Private Sub Command1_Click()
Text1(0).BackColor = &HC0FFC0: List1.BackColor = &HFFFFFF
Text1(1).Text = RecupNumeric(Text1(0).Text, HScroll1.Value)
Text1(2).Text = Val(Text1(0).Text)
End Sub
'**************** Ma fonction récupération d'un chiffre de la phrase StrSoumis ********************
Private Function RecupNumeric(StrSoumis As String, Optional Occurrence As Integer = 1) As Double
'StrSoumis, phrase ou chercher le nombre
'Occurrence, choix de la position du chiffre a récupérer
Dim Cpt As Integer ' compteur
Dim NumOccurrence As Integer ' compteur d'Occurrence
Dim NumericStr As String ' conteneur de l'entrée soumise
Dim StrNumeric As String ' conteneur de tout se qui semble numérique
Dim CharLue As String * 1 ' conteneur du caractère scanné
Dim UneDecimale As Boolean ' drapeau pour ne se limiter qu'a un séparateur décimal
NumericStr = CStr(StrSoumis)
If Len(NumericStr) = 0 Then GoTo GestErr
NumOccurrence = 1
For Cpt = 1 To Len(NumericStr)
CharLue = Mid(NumericStr, Cpt, 1)
If (CharLue = "." Or CharLue = ",") And StrNumeric = "" Then CharLue = ""
If (CharLue = "." Or CharLue = ",") And UneDecimale = True Then CharLue = ""
If IsNumeric(CharLue) Or CharLue = "." Or CharLue = "," Or CharLue = "-" Then StrNumeric = StrNumeric & CharLue
If CharLue = "." Or CharLue = "," Then
If UneDecimale = False Then UneDecimale = True Else Exit For
End If
If StrNumeric <> "" Then
If CharLue = " " And Cpt < Len(NumericStr) Then
If Not IsNumeric(Mid(NumericStr, Cpt + 1, 1)) Then
If NumOccurrence = Occurrence Then
Exit For
Else
StrNumeric = "": UneDecimale = False: NumOccurrence = NumOccurrence + 1
End If
End If
End If
End If
Next Cpt
If NumOccurrence <> Occurrence Then StrNumeric = "0"
StrNumeric = Replace(StrNumeric, ".", ",")
If IsNumeric(StrNumeric) Then RecupNumeric = CDbl(StrNumeric)
Exit Function
GestErr:
Err.Clear
RecupNumeric = 0
End Function |
Partager