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

[Abdalbagi Hassan]

😱

[زياد الحسناوي]

Function NoToTxt(TheNo As Double, MyCur As String, MySubCur As String) As String
Dim MyArry1(0 To 9) As String
Dim MyArry2(0 To 9) As String
Dim MyArry3(0 To 9) As String
Dim MyNo As String
Dim GetNo As String
Dim RdNo As String
Dim My100 As String
Dim My10 As String
Dim My1 As String
Dim My11 As String
Dim My12 As String
Dim GetTxt As String
Dim Mybillion As String
Dim MyMillion As String
Dim MyThou As String
Dim MyHun As String
Dim MyFraction As String
Dim MyAnd As String
Dim i As Integer
Dim remark As String

If TheNo > 999999999999.99 Then Exit Function

If TheNo = 0 Then
NoToTxt = "صفر"
Exit Function
End If
MyAnd = " و"
MyArry1(0) = ""
MyArry1(1) = "مائة"
MyArry1(2) = "مائتان"
MyArry1(3) = "ثلاثمائة"
MyArry1(4) = "أربعمائة"
MyArry1(5) = "خمسمائة"
MyArry1(6) = "ستمائة"
MyArry1(7) = "سبعمائة"
MyArry1(8) = "ثمانمائة"
MyArry1(9) = "تسعمائة"
MyArry2(0) = ""
MyArry2(1) = " عشر"
MyArry2(2) = "عشرون"
MyArry2(3) = "ثلاثون"
MyArry2(4) = "أربعون"
MyArry2(5) = "خمسون"
MyArry2(6) = "ستون"
MyArry2(7) = "سبعون"
MyArry2(8) = "ثمانون"
MyArry2(9) = "تسعون"
MyArry3(0) = ""
MyArry3(1) = "واحد"
MyArry3(2) = "اثنان"
MyArry3(3) = "ثلاثة"
MyArry3(4) = "أربعة"
MyArry3(5) = "خمسة"
MyArry3(6) = "ستة"
MyArry3(7) = "سبعة"
MyArry3(8) = "ثمانية"
MyArry3(9) = "تسعة"
'======================
GetNo = Format(TheNo, "000000000000.00")
i = 0
Do While i < 15
If i < 12 Then
MyNo = Mid$(GetNo, i + 1, 3)
Else
MyNo = "0" + Mid$(GetNo, i + 2, 2)
End If
If (Mid$(MyNo, 1, 3)) > 0 Then
RdNo = Mid$(MyNo, 1, 1)
My100 = MyArry1(RdNo)
RdNo = Mid$(MyNo, 3, 1)
My1 = MyArry3(RdNo)
RdNo = Mid$(MyNo, 2, 1)
My10 = MyArry2(RdNo)
If Mid$(MyNo, 2, 2) = 11 Then My11 = "إحدى عشر"
If Mid$(MyNo, 2, 2) = 12 Then My12 = "إثنى عشر"
If Mid$(MyNo, 2, 2) = 10 Then My10 = "عشرة"
If ((Mid$(MyNo, 1, 1)) > 0) And ((Mid$(MyNo, 2, 2)) > 0) Then My100 = My100 + MyAnd
If ((Mid$(MyNo, 3, 1)) > 0) And ((Mid$(MyNo, 2, 1)) > 1) Then My1 = My1 + MyAnd
GetTxt = My100 + My1 + My10
If ((Mid$(MyNo, 3, 1)) = 1) And ((Mid$(MyNo, 2, 1)) = 1) Then
GetTxt = My100 + My11
If ((Mid$(MyNo, 1, 1)) = 0) Then GetTxt = My11
End If
If ((Mid$(MyNo, 3, 1)) = 2) And ((Mid$(MyNo, 2, 1)) = 1) Then
GetTxt = My100 + My12
If ((Mid$(MyNo, 1, 1)) = 0) Then GetTxt = My12
End If
If (i = 0) And (GetTxt <> "") Then
If ((Mid$(MyNo, 1, 3)) > 10) Then
Mybillion = GetTxt + " مليار"
Else
Mybillion = GetTxt + " مليارات"
If ((Mid$(MyNo, 1, 3)) = 2) Then Mybillion = " مليار"
If ((Mid$(MyNo, 1, 3)) = 2) Then Mybillion = " ملياران"
End If
End If
If (i = 3) And (GetTxt <> "") Then
If ((Mid$(MyNo, 1, 3)) > 10) Then
MyMillion = GetTxt + " مليون"
Else
MyMillion = GetTxt + " ملايين"
If ((Mid$(MyNo, 1, 3)) = 1) Then MyMillion = " مليون"
If ((Mid$(MyNo, 1, 3)) = 2) Then MyMillion = " مليونان"
End If
End If
If (i = 6) And (GetTxt <> "") Then
If ((Mid$(MyNo, 1, 3)) > 10) Then
MyThou = GetTxt + " ألف"
Else
MyThou = GetTxt + " آلاف"
If ((Mid$(MyNo, 3, 1)) = 1) Then MyThou = " ألف"
If ((Mid$(MyNo, 3, 1)) = 2) Then MyThou = " ألفان"
End If
End If
If (i = 9) And (GetTxt <> "") Then MyHun = GetTxt
If (i = 12) And (GetTxt <> "") Then MyFraction = GetTxt
End If
i = i + 3
Loop
If (Mybillion <> "") Then
If (MyMillion <> "") Or (MyThou <> "") Or (MyHun <> "") Then Mybillion = Mybillion + MyAnd
End If
If (MyMillion <> "") Then
If (MyThou <> "") Or (MyHun <> "") Then MyMillion = MyMillion + MyAnd
End If
If (MyThou <> "") Then
If (MyHun <> "") Then MyThou = MyThou + MyAnd
End If
If MyFraction <> "" Then
If (Mybillion <> "") Or (MyMillion <> "") Or (MyThou <> "") Or (MyHun <> "") Then
NoToTxt = remark + Mybillion + MyMillion + MyThou + MyHun + " " + MyCur + MyAnd + MyFraction + " " + MySubCur
Else
NoToTxt = remark + MyFraction + " " + MySubCur
End If
Else
NoToTxt = remark + Mybillion + MyMillion + MyThou + MyHun + " " + MyCur
End If
End Function

استخدم هذا الكود 

تفقيط الارقام فى الاكسس.accdb

وهذا الكود يحول من الأرقام إلى الحروف و لكن باللغة الأنجليزية و هو بالطبع بلغة الفيجوال بيسك للتطبيقات المرفقة مع قواعد بيانات أكسس و يمكنك وضع الكود في MODULE و تسميه NumberToWrod و تقوم بعمل اللازم بعد ذلك

 

و الكود هو 

 

[B][SIZE=6][B][SIZE=3]Function ConvertCurrencyToEnglish(ByVal mynumber)

         Dim Temp
         Dim Dollars, Cents
         Dim DecimalPlace, Count

         ReDim Place(9) As String
         Place(2) = " Thousand "
         Place(3) = " Million "
         Place(4) = " Billion "
         Place(5) = " Trillion "

         ' Convert MyNumber to a string, trimming extra spaces.
         If Not mynumber = Null Then
         
         mynumber = Trim(Str(mynumber))
         
         
         End If
         

         ' Find decimal place.
         DecimalPlace = InStr(mynumber, ".")

         ' If we find decimal place...
         If DecimalPlace > 0 Then
            ' Convert cents
            Temp = Left(Mid(mynumber, DecimalPlace + 1) & "00", 2)
            Cents = ConvertTens(Temp)

            ' Strip off cents from remainder to convert.
            mynumber = Trim(Left(mynumber, DecimalPlace - 1))
         End If

         Count = 1
         Do While mynumber <> ""
            ' Convert last 3 digits of MyNumber to English dollars.
            Temp = ConvertHundreds(Right(mynumber, 3))
            If Temp <> "" Then Dollars = Temp & Place(Count) & Dollars
            If Len(mynumber) > 3 Then
               ' Remove last 3 converted digits from MyNumber.
               mynumber = Left(mynumber, Len(mynumber) - 3)
            Else
               mynumber = ""
            End If
            Count = Count + 1
         Loop

         ' Clean up dollars.
         Select Case Dollars
            Case ""
               Dollars = "Zero Dirham"
            Case "One"
               Dollars = "One Dirham"
            Case Else
               Dollars = Dollars & " Dirhams"
         End Select

         ' Clean up cents.
         Select Case Cents
            Case ""
               Cents = " And Zero Fils Only."
            Case "One"
               Cents = " And One Fils Only."
            Case Else
               Cents = " And " & Cents & " Fils Only."
         End Select

         ConvertCurrencyToEnglish = Dollars & Cents
      End Function

      Private Function ConvertHundreds(ByVal mynumber)
         Dim Result As String

         ' Exit if there is nothing to convert.
         If Val(mynumber) = 0 Then Exit Function

         ' Append leading zeros to number.
         mynumber = Right("000" & mynumber, 3)

         ' Do we have a hundreds place digit to convert?
         If Left(mynumber, 1) <> "0" Then
            Result = ConvertDigit(Left(mynumber, 1)) & " Hundred "
         End If

         ' Do we have a tens place digit to convert?
         If Mid(mynumber, 2, 1) <> "0" Then
            Result = Result & ConvertTens(Mid(mynumber, 2))
         Else
            ' If not, then convert the ones place digit.
            Result = Result & ConvertDigit(Mid(mynumber, 3))
         End If

         ConvertHundreds = Trim(Result)
      End Function

      Private Function ConvertTens(ByVal MyTens)
         Dim Result As String

         ' Is value between 10 and 19?
         If Val(Left(MyTens, 1)) = 1 Then
            Select Case Val(MyTens)
               Case 10: Result = "Ten"
               Case 11: Result = "Eleven"
               Case 12: Result = "Twelve"
               Case 13: Result = "Thirteen"
               Case 14: Result = "Fourteen"
               Case 15: Result = "Fifteen"
               Case 16: Result = "Sixteen"
               Case 17: Result = "Seventeen"
               Case 18: Result = "Eighteen"
               Case 19: Result = "Nineteen"
               Case Else
            End Select
         Else
            ' .. otherwise it's between 20 and 99.
            Select Case Val(Left(MyTens, 1))
               Case 2: Result = "Twenty "
               Case 3: Result = "Thirty "
               Case 4: Result = "Forty "
               Case 5: Result = "Fifty "
               Case 6: Result = "Sixty "
               Case 7: Result = "Seventy "
               Case 8: Result = "Eighty "
               Case 9: Result = "Ninety "
               Case Else
            End Select

            ' Convert ones place digit.
            Result = Result & ConvertDigit(Right(MyTens, 1))
         End If

         ConvertTens = Result
      End Function

      Private Function ConvertDigit(ByVal MyDigit)
         Select Case Val(MyDigit)
            Case 1: ConvertDigit = "One"
            Case 2: ConvertDigit = "Two"
            Case 3: ConvertDigit = "Three"
            Case 4: ConvertDigit = "Four"
            Case 5: ConvertDigit = "Five"
            Case 6: ConvertDigit = "Six"
            Case 7: ConvertDigit = "Seven"
            Case 8: ConvertDigit = "Eight"
            Case 9: ConvertDigit = "Nine"
            Case Else: ConvertDigit = ""
         End Select[/SIZE]
      [SIZE=3]End Function[/SIZE][/B][/SIZE][/B]

 

[Abdalbagi Hassan]

مشكور اخي زياد الحسناوي

[Moosak]

أهلا وسهلا بك أخي عبد الباقي @Abdalbagi Hassan 🙂 🌹🌼

وبما أنك عضو جديد .. تفضل عزيزي وخذ لك نبذة عن قوانين المشاركة في المنتدى :

قواعد المشاركة فى الموقع :

اضغط هنـــــــــامن فضلك لقراءة القواعد كاملة

ولا تنسى استخدام خاصية البحث للحصول على النتائج السابقة عن المواضيع التي تحتاجها وقبل أن تسأل عنها :