31-07-13, 09:46 PM
الادوات المطلوبة :
- text1 نسميه TxtNombre
- label 1 نسميها LblConverti
- commande نسميه CmdConvertir
- commande نسميه CmdFin
- commande نسميه CmdNewConv
- فورمة واحدة
- Module
- class Module
اذا ننطلق في البرمجة ضع هذا الكود في الفورمة التي نسميها FrmPrincipale :
[SIZE=5]نظيف [/SIZE]Module و نسمه ModuleChLet و نظيف له الكود التالي
نظيف classmodule و نسمه ClsChiffresEnLettres و نظيف له الكود التالي
- text1 نسميه TxtNombre
- label 1 نسميها LblConverti
- commande نسميه CmdConvertir
- commande نسميه CmdFin
- commande نسميه CmdNewConv
- فورمة واحدة
- Module
- class Module
اذا ننطلق في البرمجة ضع هذا الكود في الفورمة التي نسميها FrmPrincipale :
كود :
Option Explicit
Dim ClsConvertir As ClsChiffresEnLettres
Private Sub CmdConvertir_Click()
' instanciation de la classe dans laquelle se trouve la fonction de conversion
Set ClsConvertir = New ClsChiffresEnLettres
Dim Nombre As Variant
Nombre = TxtNombre.Text
' appel de la classe en donnant le nombre à convertir
ClsConvertir.NombreChiffres = Nombre
' puis appel pour convertir réellement ce nombre
LblConverti.Caption = ClsConvertir.Conversion(Nombre)
CmdNewConv.Visible = True
End Sub
Private Sub CmdFin_Click()
Unload Me
End
End Sub
Private Sub CmdNewConv_Click()
LblConverti.Caption = ""
TxtNombre.Text = ""
TxtNombre.SetFocus
CmdNewConv.Visible = False
End Sub
Private Sub Form_Load()
ImgFond.Picture = LoadPicture(App.Path & "\confetti.jpg")
TxtNombre.Text = ""
End Sub
Private Sub Form_Resize()
ImgFond.Move 0, 0, ScaleWidth, ScaleHeight
End Sub
Private Sub TxtNombre_KeyPress(KeyAscii As Integer)
Select Case KeyAscii
Case Asc(".") ' change le "." en ","
KeyAscii = Asc(",")
Case 8 ' gère le backspace
TxtNombre = Left(TxtNombre, Len(TxtNombre))
Case 48 To 57, Asc(",") ' accepte si c'est un chiffre correct
Case Else 'n'inscrit rien si c'est un caractère incorrect
KeyAscii = 0
End Select
End Sub[SIZE=5]نظيف [/SIZE]Module و نسمه ModuleChLet و نظيف له الكود التالي
كود :
Option Explicit
' j'ai pris le principe du fichier ini pour lire dans un fichier la traduction en lettre des chiffres
' il suffit donc de changer ce fichier pour avoir les chiffres dans une autre langue
' et aussi d'adapter un peu la routines (par ex pour les français : 70 = soixante-dix)
Public CheminFichierLettres As String
Private Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" _
(ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, _
ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Private Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" _
(ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, _
ByVal lpFileName As String) As Long
Public fMainForm As FrmPrincipale
Sub main()
Set fMainForm = New FrmPrincipale
CheminFichierLettres = App.Path & "\ChToLet.ini"
fMainForm.Show
End Sub
Public Function EcritDansFichierLettres(Section As String, Cle As String, _
Valeur As String, Fichier As String) As Long
EcritDansFichierLettres = WritePrivateProfileString(Section, Cle, Valeur, Fichier)
End Function
Public Function LitDansFichierLettres(Section As String, Cle As String, Fichier As String, _
Optional ValeurParDefaut As String = "") As String
Dim strReturn As String
strReturn = String(255, 0)
GetPrivateProfileString Section, Cle, ValeurParDefaut, strReturn, Len(strReturn), Fichier
LitDansFichierLettres = Left(strReturn, InStr(strReturn, Chr(0)) - 1)
End Functionنظيف classmodule و نسمه ClsChiffresEnLettres و نظيف له الكود التالي
كود :
Option Explicit
'variables locales de stockage des valeurs de propriétés
Private mvarNombreChiffres As Variant 'copie locale
Private mvarNombreLettres As String 'copie locale
Public Function Conversion(ByVal nb As String) As String
Dim NbDeci As String
Dim Affichage As String
Dim Entier As String
Dim Décimal As String
If InStr(nb, ",") = 0 Then ' un entier
Affichage = Decodage(nb)
Else ' un décimal
Do While Right(nb, 1) = "0" 'suppression des zéros à droite de la partie décimale
If Right(nb, 1) = "0" Then nb = Left(nb, Len(nb) - 1)
Loop
Entier = Decodage(Left(nb, InStr(nb, ",") - 1))
If Right(Entier, 2) = "un" Then Entier = Entier & "e"
If Entier = "une" Then
Entier = Entier & " unité "
Else
If Entier <> "" Then
Entier = Entier & " unités "
End If
End If
Décimal = Decodage(Mid(nb, InStr(nb, ",") + 1))
Affichage = Entier & Décimal & " "
' calcul du nombre de décimales
NbDeci = Len(Mid(nb, InStr(nb, ",") + 1))
Affichage = Affichage & LitDansFichierLettres("Decimale", NbDeci, CheminFichierLettres)
If Décimal <> "un" Then Affichage = Affichage & "s"
End If
Conversion = Affichage
End Function
Public Property Let NombreLettres(ByVal vData As String)
'utilisé lors de l'affectation d'une valeur à la propriété, du coté gauche de l'affectation.
'Syntax: X.NombreLettres = 5
mvarNombreLettres = vData
End Property
Public Property Get NombreLettres() As String
'utilisé lors de la lecture de la valeur de la propriété, du coté droit de l'instruction.
'Syntax: Debug.Print X.NombreLettres
NombreLettres = mvarNombreLettres
End Property
Public Property Let NombreChiffres(ByVal vData As Variant)
'utilisé lors de l'affectation d'une valeur à la propriété, du coté gauche de l'affectation.
'Syntax: X.NombreChiffres = 5
mvarNombreChiffres = vData
End Property
Public Property Get NombreChiffres() As Variant
'utilisé lors de la lecture de la valeur de la propriété, du coté droit de l'instruction.
'Syntax: Debug.Print X.NombreChiffres
If IsObject(mvarNombreChiffres) Then
Set NombreChiffres = mvarNombreChiffres
Else
NombreChiffres = mvarNombreChiffres
End If
End Property
Private Function Decodage(ByVal nb As String) As String
Dim nb1 As String
Do While Left(nb, 1) = "0"
If Left(nb, 1) = "0" Then nb = Mid(nb, 2) 'suppression des zéros à gauche
Loop
Select Case Len(nb)
Case 0
Decodage = ""
Case 1
Decodage = LitDansFichierLettres("Chiffres", nb, CheminFichierLettres)
Case 2
If nb < 17 Then
Decodage = LitDansFichierLettres("Chiffres", nb, CheminFichierLettres)
Else
nb1 = nb - Right(nb, 1)
Decodage = LitDansFichierLettres("Chiffres", nb1, CheminFichierLettres)
nb1 = Right(nb, 1)
Decodage = Decodage & "-" & LitDansFichierLettres("Chiffres", nb1, CheminFichierLettres)
End If
If Right(Decodage, 2) = "un" And nb > 20 Then Decodage = Left(Decodage, Len(Decodage) - 2) & "et un"
If Right(Decodage, 4) = "zéro" Then Decodage = Left(Decodage, Len(Decodage) - 5)
Case 3
Select Case Left(nb, 1)
Case "1"
Decodage = "cent " & Decodage(Mid(nb, 2))
Case Else
Decodage = Decodage(Left(nb, 1)) & " cent " & Decodage(Mid(nb, 2))
If Right(Decodage, 6) = " cent " Then Decodage = Left(Decodage, Len(Decodage) - 1) & "s"
End Select
Case 4 To 6
Decodage = Decodage(Left(nb, Len(nb) - 3)) & " mille " & Decodage(Right(nb, 3))
If Left(Decodage, 2) = "un" Then Decodage = Mid(Decodage, 4)
Case 7 To 9
Decodage = Decodage(Left(nb, Len(nb) - 6)) & " millions " & Decodage(Right(nb, 6))
If Left(Decodage, 2) = "un" Then Decodage = Left(Decodage, 10) & Mid(Decodage, 12)
Case 10 To 12
Decodage = Decodage(Left(nb, Len(nb) - 9)) & " milliards " & Decodage(Right(nb, 9))
If Left(Decodage, 2) = "un" Then Decodage = Left(Decodage, 11) & Mid(Decodage, 13)
End Select
End Function
{وَسَارِعُواْ إِلَى مَغْفِرَةٍ مِّن رَّبِّكُمْ وَجَنَّةٍ عَرْضُهَا السَّمَاوَاتُ وَالأَرْضُ أُعِدَّتْ لِلْمُتَّقِينَ }آل عمران133
