دالة تفقيط الارقام ( بالريال)

mada4top · يوليو 7, 2014

السلام عليكم

اولا احب اشكر جميع القائمين علي هذا المنتدي الاكثر من رائع وانا شخصيا تعلمت منكم الكثير

وايضا بشكر كل الاعضاء المشاركين

الحقيقة كان عندي كود التفقيط لكن فيه غلط بسيط كده وحاولت اعدله لكن للاسف ومابقاش بيستغل اصلا

انا محتاج كود التفقيط باللغة العربية بالريال ولو امكن يكون بالإنجليزية كمان

خزاني · يوليو 7, 2014

السلام عليكم

تغـيـيـر ديـنار بــــــــــــــــــــــ: ريـال

وضع هذا فى الخلبة (NbLettresArabes(H6=

' ---------------------------------------------
' FONCTION DE TRADUCTION D'UNE SOMME EN LETTRES
' ---------------------------------------------
Option Explicit
Option Base 1

Public Unité As Variant
Public Dizaine As Variant
Public Décimales As Currency
Public CasPart As Variant
Public Lettres As String
Public Cent_Pluriel As Boolean
' -------------------
' FONCTION PRINCIPALE
' -------------------
'
Function NbLettresArabes(Nombre As Currency) As String

' Limitation à 999 999 999 999 . 99
    If Nombre >= 1000000000000# Then
        MsgBox "! هاذ العدد كبير", 0, "Message"
        Exit Function
    End If
    
' Initialisation des tableaux
    Unité = Array("واحد", "اثنان", "ثلاثة", "أربعة", "خمسة", "ستة", "سبعة", "ثمانية ", "تسعة")
    Dizaine = Array("عشرة", "عشرون", "ثلاثون", "اربعون", "خمسون", "ستون", "سبعون", "ثمانون", "تسعون")
    CasPart = Array("عشرة", "احد عشرة", "اثن عشرة", "ثلاثة عشرة", "أربعة عشرة", "خمسةعشرة", "ستةعشرة", "سبعةعشرة", "ثمانية  عشرة", "تسعة عشرة")
    
' Mise à vide de la chaîne de réception de la traduction du nombre
    Lettres = ""
    
' Initialisation des indicateurs de pluriel des nombres cent et vingt
    Cent_Pluriel = True
        
' Conversion de la partie décimale en un nombre de 0 à 99
' arrondi à l'unité la plus proche
    Décimales = CInt((Nombre - Fix(Nombre)) * 100)
    
' Conservation de la partie entière du nombre
    Nombre = Fix(Nombre)
    
' Orientation du traitement suivant valeur de la partie entière
    Select Case Nombre
        Case 0
            Lettres = "صفر" 'Zéro
        Case 1 To 9
            Lettres = Unité(CInt(Nombre))
        Case 10 To 99
            Trt_Dizaines Nombre
        Case 100 To 999
            
            Trt_Centaines Nombre
                   
        Case 1000 To 999999999999#
            Trt_Multiples_de_Mille Nombre
    End Select
         
' Indication de la monnaie
        
        If Décimales > 0 Then
            Lettres = Lettres & " دينار " + " و "
Else
       If Décimales = 0 Then
            
            Lettres = Lettres & " دينار " ' + " و "
  
        End If
    End If

' Orientation du traitement suivant valeur de la partie décimale
    Select Case Décimales
        Case 1 To 9
            Lettres = Lettres & Unité(CInt(Décimales))
        Case 10 To 99
        
            Trt_Dizaines Décimales
    End Select
        
' Indication des centimes
    Select Case Décimales
        Case 1
            Lettres = Lettres & " سنتيم" ' Centimes'" و" +
        Case Is > 1
            Lettres = Lettres & " سنتيم"  ' Centimes
        Case Is < 1
            Lettres = Lettres ' & " سنتيم" ' Centimes
    End Select

' Renvoi du nombre traduit en lettres
If Lettres = "صفر" & " دينار " Then
                   Lettres = ""
                   Else
    NbLettresArabes = Lettres
    End If
    End Function
' --------------------------------
' TRAITEMENT DES MULTIPLES DE 1000
' --------------------------------
Sub Trt_Multiples_de_Mille(Nombre As Currency)

Dim Rank As Currency
Dim Nom_Rang As String
Dim Reste As Currency

    Cent_Pluriel = False
  ' Initialisation suivant taille du nombre : milliers, millions ou milliards
    Select Case Nombre
        Case 1000 To 999999
            Rank = Fix(Nombre / 1000)
            Reste = Nombre Mod 1000
            Nom_Rang = "ألف" ' Mille
        Case 1000000 To 999999999
            Rank = Fix(Nombre / 1000000)
            Reste = Nombre Mod 1000000
            If Rank > 1 Then
                Nom_Rang = "مليون" 'Millions
            Else
                Nom_Rang = "مليون" '  Million
            End If
        Case Is > 999999999
            Rank = Fix(Nombre / 1000000000)
            Reste = Nombre - Rank * 1000000000
            If Rank > 1 Then
                Nom_Rang = "ميليار" ' Milliard
            Else
                Nom_Rang = "ميليار" ' Milliard
            End If
    End Select
    
' Traitement du rang des milliers, millions ou milliards
    Select Case Rank
        Case 1
            If Nom_Rang = "الف" Then
                Lettres = Lettres & "آلاف"
            Else
                Lettres = Lettres & Unité(CInt(Rank)) & " " & Nom_Rang '& " و"
            End If
        Case 2
            
            Lettres = Lettres & Unité(CInt(Rank)) & " " & Nom_Rang '& " و"
             
             Case 3 To 9
           
            Lettres = Lettres & Unité(CInt(Rank)) & " " & Nom_Rang '& " و"
        Case 10 To 99
       
            Trt_Dizaines (Rank)
            Lettres = Lettres & " " & Nom_Rang '& " و"
        Case 100 To 999
        
            Trt_Centaines Rank
            Lettres = Lettres & " " & Nom_Rang '& " و"
    End Select
        
    Cent_Pluriel = True
    
' Orientation du traitement du reste si > 0
   
    Select Case Reste
                
        Case 1 To 9
         
            Lettres = Lettres & " و" & " " & Unité(CInt(Reste))
           
        Case 10 To 99
     
            Lettres = Lettres & " و" & " "
            Trt_Dizaines Reste
        Case 100 To 999
            Lettres = Lettres & " و" & " "
            Trt_Centaines Reste
        Case Is > 999
            Lettres = Lettres & " و" & " "
            Trt_Multiples_de_Mille Reste
        Case Else
       
            Lettres = Lettres & " "
    End Select
    
    Lettres = Lettres
 

End Sub
' -----------------------------------
' TRAITEMENT DES NOMBRES DE 100 0 999
' -----------------------------------
Sub Trt_Centaines(Nombre As Currency)

Dim Rank As Currency
Dim Reste As Currency

    Rank = Fix(Nombre / 100)
    Reste = Nombre Mod 100
  ' Traitement du rang des centaines
   
    If Rank = 1 Then
        If Reste = 0 Then
            Lettres = Lettres & "مائة" '& " و"
        
        Else
            Lettres = Lettres & "مائة" & " و"
        End If
    Else
       If Reste = 0 And Cent_Pluriel Then
            Lettres = Lettres & Unité(CInt(Rank)) & " " & "مئات"
         Else
            Lettres = Lettres & Unité(CInt(Rank)) & " " & "مئات" & " و"
        End If
    End If
   
' Traitement du reste < 100
    Select Case Reste
        Case 1 To 9
             Lettres = Lettres & " " & Unité(CInt(Reste))
            
        Case Is > 9
      
            Lettres = Lettres & " "
            Trt_Dizaines (Reste)
         End Select
   End Sub
' ---------------------------------
' TRAITEMENT DES NOMBRES DE 10 0 99
' ---------------------------------
Sub Trt_Dizaines(Nombre As Currency)

Dim Reste As Integer
Dim Rank As Integer
    Rank = Fix(Nombre / 10)
    Reste = Nombre Mod 10
    Select Case Rank
        Case 1
             Lettres = Lettres & CasPart(Reste + 1)
            Case 7
            Select Case Reste
                Case 0
                    ' Nombre 70
                  Lettres = Lettres & Dizaine(Rank)
                Case Else
                    ' Nombre 71  à 76
                  Lettres = Lettres & Unité(CInt(Reste)) & " و " & Dizaine(Rank)
               End Select
        Case 8
            If Reste = 0 Then
                ' Nombre 80
                Lettres = Lettres & Dizaine(Rank)
            Else
                ' Nombres 81 à 89
                Lettres = Lettres & Unité(CInt(Reste)) & " و " & Dizaine(Rank)
            End If
        Case 9
            If Reste = 0 Then
                ' Nombres 90
             Lettres = Lettres & Dizaine(Rank)
                Else
                ' Nombres 91 à 99
             Lettres = Lettres & Unité(CInt(Reste)) & " و " & Dizaine(Rank)
            End If
        Case Else
            ' Nombres 20 à 69
            Select Case Reste
                Case 0
                    ' Nombres 20, 30, 40, 50, 60
                    Lettres = Lettres & Dizaine(Rank)
                Case Else
                    ' Autres nombres
                    Lettres = Lettres & Unité(CInt(Reste)) & " و " & Dizaine(Rank)
                     
            End Select
    End Select
   End Sub

**أم عبد الله** · يوليو 8, 2014

الأستاذ /mada4top

السلام عليكم ورحمة الله وبركاته

بعد إذن الأستاذ / خزاني جزاه الله خيراً على الكود وإليك الملف به تفيط عربي وانجليزي .

تفقيط بالريال.rar

تفقيط انجليزي.rar

mada4top · يوليو 9, 2014

اخي خزاني

بارك الله فيك وجزاك الله خيرا

mada4top · يوليو 9, 2014

ام عبدالله

متشكرا جدا لاهتمام حضرتك

ملفات رائعة

ziad_alali2001@hotmail.com · نوفمبر 19, 2018

شكرا

تسجيل الدخول

دالة تفقيط الارقام ( بالريال)

الردود الموصى بها

mada4top

رابط هذا التعليق

شارك

خزاني

رابط هذا التعليق

شارك

أم عبد الله

رابط هذا التعليق

شارك

mada4top

رابط هذا التعليق

شارك

mada4top

رابط هذا التعليق

شارك

ziad_alali2001@hotmail.com

رابط هذا التعليق

شارك

Join the conversation

تصفح هذا الموضوع مؤخراً 0 اعضاء متواجدين الان

تصفح الموقع

تصفح جديد الموقع

Support

Important Information