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
| Option Explicit
Dim NbrCaract As Integer ' pour calcul du nombre d'espace pour un calage à droite d'un conteneur qui n'a pas de propriété .Alignement
Dim Cpt As Integer ' divers boucles
Private Sub Form_Load()
Label1.Caption = "Nbr. de dec. :": Label1.Move 120, 120, 975, 195
With Textdecimal ' pour le choix du nombre de décimale
.Text = "0": .Alignment = 2: .Appearance = 0: .Move 1140, 60, 435, 285
End With
With CheckCallage ' pour un calage à droite ou non
.Caption = "callage à droite": .Value = 0: .Move 1740, 60, 1755, 315
End With
With TextEntrer ' pour les essais
.Appearance = 0
.BorderStyle = 1
.BackColor = &H80C0FF
.Text = ""
.FontName = "Courier New": .FontBold = True: .FontSize = 14
.Move 120, 480, 3435, 450
End With
With TextRersult ' pour l'affichage après passage de la fonction FormatStr
.Text = "": .Appearance = 0: .BorderStyle = 1: .FontName = "Courier New": .Move 120, 960, 3435, 435
End With
With LabCaractMax ' témoin pour la grandeur de décalage à droite
.Appearance = TextRersult.Appearance
.BorderStyle = TextRersult.BorderStyle
.FontName = TextRersult.FontName
.FontBold = TextRersult.FontBold
.FontSize = TextRersult.FontSize
.AutoSize = True
.Move 120, 1440
For Cpt = 1 To 50
.Caption = String(Cpt, " ")
If .Width >= TextRersult.Width Then NbrCaract = Cpt - 1: Exit For
Next Cpt
End With
Form1.BorderStyle = 1: Form1.Caption = "Étude formatage chiffre"
Me.Height = 2310: Me.Width = 3765
End Sub
Private Sub TextEntrer_KeyPress(KeyAscii As Integer)
Select Case KeyAscii
Case 44: KeyAscii = 46 'transforme la virgule en point
Case 8, 13, 46, 48 To 57 ' les touches RET.ARR, Entrer, virgule et les chiffres sont autorisés
Case Else: KeyAscii = 0: Exit Sub 'toutes autres touches sont annulées
End Select
If KeyAscii = 46 And InStr(1, TextEntrer.Text, ".", vbTextCompare) Then
'déclenchement sur 2éme séparateur décimale, supprime le dernier entré et qui la sub
KeyAscii = 0: Beep: Exit Sub
End If
If KeyAscii = vbKeyReturn Then ' l'entrée a été validée
KeyAscii = 0 'supprime le ENTER
If Trim(TextEntrer.Text) = "" Then MsgBox "vous devez entrer un nombre", vbInformation, "Erreur": Exit Sub
'************************** Exemple d'utilisation de la fonction FormatStr *************************************
TextRersult.Text = "" ' efface le contrôle conteneur d'affichage de la sortie
If Textdecimal.Text = "" Then Textdecimal.Text = "0"
If CheckCallage.Value = 0 Then
'-------------- le chiffre est un entier ------------------------------------------
'*** Exemple d'appel pour faire un affichage sans calcul ***
TextRersult.Text = FormatStr(TextEntrer.Text, Textdecimal.Text)
'*** Exemple d'appel pour faire un calcul ***
'TextRersult.Text = Val(FormatStr(TextEntrer.Text, Textdecimal.Text)) + 15
Else
'-------------- le chiffre est un entier avec décimale(s) -------------------------
'*** Exemple d'appel pour faire un affichage sans calcul ***
'TextRersult.Text = FormatStr(TextEntrer.Text, Textdecimal.Text, NbrCaract)
'*** Exemple d'appel pour faire un calcul, NbrCaract ne sera pas pris en compte ***
TextRersult.Text = Val(FormatStr(TextEntrer.Text, Textdecimal.Text, NbrCaract)) + 15
'donc en plus court
'TextRersult.Text = Val(FormatStr(TextEntrer.Text, Textdecimal.Text)) + 15
End If
End If
End Sub
Function FormatStr(Valeur As Variant, Optional NbrDecimale As Integer = 0, Optional NbrCaractConteneur As Integer = 0) As String
Dim T As Integer, PoS As Integer ' pour la boucle, pour position (utilisé dans la fonction InStr())
Dim EntierStr As String, DecimalStr As String ' partie entière, partie décimale
'*-*-*-*-* Utile si la donnée "Valeur" provient par exemple d'une Base de données ou lecture d'un automatisme
'en bref n'est pas un chiffre
If Valeur = vbNull Or Valeur = vbNullChar Or Valeur = vbNullString Then Valeur = 0 '*-*-*-*-*
If Trim(FormatStr) = "" Then FormatStr = "0" '*-*-*-*-*
FormatStr = CStr(Valeur) 'force la variable d'entrée en String
FormatStr = Replace(FormatStr, " ", "") '*-*-*-*-*
FormatStr = Replace(FormatStr, ",", ".") '*-*-*-*-*
FormatStr = Trim(FormatStr) 'supprime les éventuels espaces à gauche et à droite '*-*-*-*-*
FormatStr = Val(FormatStr) ' extraction du chiffre, si juste un point ou non un chiffre, FormatStr = "0"
If FormatStr = "0" Then If NbrDecimale <> 0 Then FormatStr = "0." & String(NbrDecimale, "0")
FormatStr = Replace(FormatStr, ",", ".") 'Val() peut avoir transformé le point en virgule suivant le séparateur système
PoS = InStr(1, FormatStr, ".", vbTextCompare) ' vérification de la position du point décimale
If PoS <> 0 Then
EntierStr = Left(FormatStr, PoS - 1) 'récupère la partie entière
For T = 1 To Len(EntierStr) ' élimine les zéro non significatif de la partie entière
If Mid(EntierStr, T, 1) = "0" Then EntierStr = Right(EntierStr, 1) Else Exit For
Next T
If EntierStr = "" Then EntierStr = "0"
DecimalStr = Right(FormatStr, Len(FormatStr) - PoS) 'récupère la partie décimale
If Len(DecimalStr) > NbrDecimale Then DecimalStr = Left(DecimalStr, NbrDecimale) ' ajout de zéro à la partie décimale
Else
EntierStr = FormatStr ' "Valeur" est un entier
End If
If NbrDecimale = 0 Then FormatStr = EntierStr Else FormatStr = EntierStr & "." & DecimalStr
FormatStr = StrReverse(FormatStr) ' retourne le chiffre pour avoir les décimales à gauche
PoS = InStr(1, FormatStr, ".", vbTextCompare) ' vérification de la position du point décimale
'PoS, pour 1 décimales devrait être égal à 2, pour 2 décimales, devrait être égal à 3, pour 3 décimales, devrait être égal à 4 .....
If NbrDecimale <> 0 Then 'ajoute éventuellement les décimales pour être égal à NbrDecimale
If PoS <= NbrDecimale Then FormatStr = String((NbrDecimale + 1) - PoS, "0") & FormatStr
End If
FormatStr = StrReverse(FormatStr) ' retourne le chiffre
'Formatage, purement pour l'affichage à gauche
If NbrCaractConteneur <> 0 Then
'formatage avec déplacement du chiffre vers la droite suivant le NbrCaract max du contrôle conteneur
If NbrCaractConteneur >= Len(FormatStr) Then
FormatStr = String(NbrCaractConteneur - Len(FormatStr), " ") & FormatStr
End If
End If
End Function |
Partager