إليكم : دالة التفقيط المحسنة المبسطة NoToTxt

[Moosak]

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

نزولا عند رغبة شيخنا الفاضل @ابوخليل تم إضافة تحسين بسيط على دالة التفقيط المبسطة لتعميم الفائدة ..

طبعا الدالة كانت تأخذ 3 أرقام من كسر العملة هكذا ( 143.487 ) وهذا ينطبق على بعض العملات كالريال العماني والبيسة العمانية

بينما أن هناك الكثير من العملات تعتمد 2 رقمين لكسر العملة مثال الريال والهللة السعودية والجنيه والقرش المصري هكذا ( 123.45 )

والتعديل الذي تم إجراؤه هو إضافة معامل رابع للدالة للتحكم في هذا الاختلاف واختيار عدد أرقام كسر العملة 2 أو 3 حسب الحاجة ..

 

بدون إطالة إليكم الدالة كاملة .. وكذلك تم إضافة ملف جاهز ليبين طريقة الاستخدام : 🙂 

Option Compare Database
Option Explicit


Function NoToTxt(TheNo As Double, _
                 MyCur As String, _
                 MySubCur As String, _
                 Optional FractionDigits As Integer = 3 _
                 ) As String

'----------------------------------
' دالة التفقيط المحسنة
' TheNo : المبلغ
' MyCur : العملة الرئيسية
' MySubCur : جزء العملة
' FractionDigits : عدد أرقام جزء العملة 2 أو 3
'----------------------------------
' : أمثلة على الاستخدام
' NoToTxt(15.436, "ريال عماني", "بيسة")
' NoToTxt(15.43, "ريال", "هللة", 2 )
' NoToTxt2(15.436, "ريال", "بيسة", 3)
'----------------------------------
    
    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 Integer
    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
    
    Dim IntegerPart As Double
    Dim FractionPart As Long
    Dim ScaleNo As Double
    
    ' عدد خانات الكسر المسموح بها
    ' الدالة الحالية تقرأ الجزء العشري كمجموعة من 3 أرقام، لذلك الحد الأعلى 3
    If FractionDigits < 0 Then FractionDigits = 0
    If FractionDigits > 3 Then FractionDigits = 3
    
    If Abs(TheNo) > 999999999999.999 Then Exit Function
    
    If TheNo < 0 Then
        TheNo = TheNo * -1
        ReMark = "عليه مبلغ "
    Else
        ReMark = "له مبلغ "
    End If
    
    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) = "تسعة"
    
    '======================
    ' تجهيز الرقم حسب عدد الخانات المطلوبة بعد الفاصلة
    ' مثال:
    ' FractionDigits = 2  يجعل 15.436 تقرأ كـ 15.44
    ' FractionDigits = 3  يجعل 15.436 تقرأ كـ 15.436
    
    TheNo = Round(TheNo, FractionDigits)
    
    IntegerPart = Fix(TheNo)
    
    If FractionDigits = 0 Then
        FractionPart = 0
    Else
        ScaleNo = 10 ^ FractionDigits
        FractionPart = CLng(Round((TheNo - IntegerPart) * ScaleNo, 0))
    End If
    
    ' معالجة حالة التقريب التي قد ترفع الجزء العشري إلى 100 أو 1000
    If FractionDigits > 0 Then
        If FractionPart >= ScaleNo Then
            IntegerPart = IntegerPart + 1
            FractionPart = 0
        End If
    End If
    
    ' الجزء الصحيح 12 رقم + الجزء العشري دائمًا 3 أرقام داخليًا
    ' عند اختيار خانتين مثلًا 44 يتم تخزينها كـ 044 حتى تُقرأ أربعون وأربعة
    GetNo = Format(IntegerPart, "000000000000") & "." & Format(FractionPart, "000")
    
    i = 0
    
    '===============
    Do While i < 16
    
        My100 = ""
        My10 = ""
        My1 = ""
        My11 = ""
        My12 = ""
        GetTxt = ""
    
        If i < 12 Then
            Myno = Mid$(GetNo, i + 1, 3)
        Else
            Myno = Mid$(GetNo, i + 2, 3)
        End If
    
        If Val(Mid$(Myno, 1, 3)) > 0 Then
    
            RdNo = Val(Mid$(Myno, 1, 1))
            My100 = MyArry1(RdNo)
    
            RdNo = Val(Mid$(Myno, 3, 1))
            My1 = MyArry3(RdNo)
    
            RdNo = Val(Mid$(Myno, 2, 1))
            My10 = MyArry2(RdNo)
    
            If Val(Mid$(Myno, 2, 2)) = 11 Then My11 = "احدى عشر"
            If Val(Mid$(Myno, 2, 2)) = 12 Then My12 = "اثني عشر"
            If Val(Mid$(Myno, 2, 2)) = 10 Then My10 = "عشرة"
    
            If Val(Mid$(Myno, 1, 1)) > 0 And Val(Mid$(Myno, 2, 2)) > 0 Then
                My100 = My100 & MyAnd
            End If
    
            If Val(Mid$(Myno, 3, 1)) > 0 And Val(Mid$(Myno, 2, 1)) > 1 Then
                My1 = My1 & MyAnd
            End If
    
            GetTxt = My100 & My1 & My10
    
            If Val(Mid$(Myno, 3, 1)) = 1 And Val(Mid$(Myno, 2, 1)) = 1 Then
                GetTxt = My100 & My11
                If Val(Mid$(Myno, 1, 1)) = 0 Then GetTxt = My11
            End If
    
            If Val(Mid$(Myno, 3, 1)) = 2 And Val(Mid$(Myno, 2, 1)) = 1 Then
                GetTxt = My100 & My12
                If Val(Mid$(Myno, 1, 1)) = 0 Then GetTxt = My12
            End If
    
            If i = 0 And GetTxt <> "" Then
                If Val(Mid$(Myno, 1, 3)) > 10 Then
                    Mybillion = GetTxt & " مليار"
                Else
                    Mybillion = GetTxt & " مليارات"
                    If Val(Mid$(Myno, 1, 3)) = 1 Then Mybillion = " مليار"
                    If Val(Mid$(Myno, 1, 3)) = 2 Then Mybillion = " ملياران"
                End If
            End If
    
            If i = 3 And GetTxt <> "" Then
                If Val(Mid$(Myno, 1, 3)) > 10 Then
                    MyMillion = GetTxt & " مليون"
                Else
                    MyMillion = GetTxt & " ملايين"
                    If Val(Mid$(Myno, 1, 3)) = 1 Then MyMillion = " مليون"
                    If Val(Mid$(Myno, 1, 3)) = 2 Then MyMillion = " مليونان"
                End If
            End If
    
            If i = 6 And GetTxt <> "" Then
                If Val(Mid$(Myno, 1, 3)) > 10 Then
                    MyThou = GetTxt & " الف"
                Else
                    MyThou = GetTxt & " الاف"
                    If Val(Mid$(Myno, 1, 3)) = 1 Then MyThou = " الف"
                    If Val(Mid$(Myno, 1, 3)) = 2 Then MyThou = " الفان"
                End If
            End If
    
            If i = 9 And GetTxt <> "" Then MyHun = GetTxt
    
            If i = 12 And GetTxt <> "" Then
                If FractionDigits > 0 Then
                    MyFraction = GetTxt
                End If
            End If
    
        End If
    
        i = i + 3
    
    Loop
    
    '============================
    If Mybillion <> "" Then
        If MyMillion <> "" Or MyThou <> "" Or MyHun <> "" Then
            Mybillion = Mybillion & MyAnd
        End If
    End If
    
    If MyMillion <> "" Then
        If MyThou <> "" Or MyHun <> "" Then
            MyMillion = MyMillion & MyAnd
        End If
    End If
    
    If MyThou <> "" Then
        If MyHun <> "" Then
            MyThou = MyThou & MyAnd
        End If
    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

NoToTxt.accdb

[ابوخليل]

جزاك الله خيرا .. وكتبها في موازين أعمالك

[M.Abd Allah]

ابدعت يا دكتور 

[منتصر الانسي]

عمل رائع أخي @Moosak وإثراءً للموضوع أرفق لكم مثالين

الاول للأستاذ الغالي @عبدالله باقشير الله يذكره بالخير (كان مشرفاً لمنتدى أكسل وكان إسمه في المنتدى خبور خير)

حيث أنه قد قام بتغطية كل ماجاء في هذا المثال مع إضافة بعض الإضافات الجميلة التي يمكن أن يراها البعض مهمة ولعل أهمها

- طريقة كتابة إسم العملة للأرقام من 3 إلى 10 (مثال خمسة ريالات وليس خمسة ريال)

- إمكانية تفقيط رقم يصل إلى البلايين (مايزيد عن 999 مليار)

المثال الآخر للأستاذ الكبير أبو هادي (لن يعرفه إلا القدامى 😅) ويشبه مثال الاخ عبدالله كثيراً ولكنه يتميز عنه بأنه ثنائي اللغة فيمكنك التفقيط باللغتين العربية والإنجليزية 

فلو أمكنك أستاذ موسى الإطلاع على المثالين لترى إذا ماكان بإمكانك إضافة الخيارات الإضافية التي وردت فيها لتخرج بعمل أكثر تكاملاً 

 

أمثلة للتفقيط.rar

[شايب]

52 دقائق مضت, منتصر الانسي said:

- طريقة كتابة إسم العملة للأرقام من 3 إلى 10 (مثال خمسة ريالات وليس خمسة ريال)

تمييز الاعداد من 3 الى 10 يكون جمع مجرور بالاضافة ويخالف العدد المعدود في التذكير والتانيث

خمسة ريالات

الريال مذكر فتكتب خمسة كما اشار الاستاذ منتصر

خمس ليرات

ليرة مؤنتة تأنيث لفضي فيكتب العدد خمس

الاعداد 1 و 2 يوافق العدد المعدود تذكيرا وتانيثا ويسبق المعدود العدد 

رجل واحد

سيارة واحدة

العدد 2 يعرب اعراب المثنى فيرفع بالالف وينصب ويجر بالياء

العدد 11 و 12 يطابق العدد المعدود وتمييزهما مفرد منصوب
العدد 11 يبنى على فتح الجزاين و12 يعرب اعراب المثنى

الاعداد 13 - 19 يخالف الجزء الأول من العدد المعدود والجزء الثاني يطابقه في التذكير والتانيث والتميز مفرد منصوب والعدد مبني على فتح الجزاين
حضر خمسة عشر طالبا
نجحت ثلاث عشرة طالبة

الفاض العقود تعرب اعراب جمع المذكر فترفع بالواو وتنصب وتجر بالياء وتمييزها مفرد منصوب ولا تتاثر بالتأنيث والتذكير 

قرأتُ عشرينَ كتاباً

شاهدت عشرين طالبا

مررت بعشرين طالبا

الاعداد 100 و 1000 و الخ تمييزها مفرد مجرور بالاضافة

لماذا هذه المشاركة ربما ينتفع بها احدهم

املاه اخونا الشايب

تم تعديل منذ 16 ساعات بواسطه شايب

[Moosak]

15 ساعات مضت, منتصر الانسي said:

فلو أمكنك أستاذ موسى الإطلاع على المثالين لترى إذا ماكان بإمكانك إضافة الخيارات الإضافية التي وردت فيها لتخرج بعمل أكثر تكاملاً 

جزيل الشكر لك عزيزي باشمهندس @منتصر الانسي على المشاركة 🙂 

فعلا مر علي ملف الأستاذ أبو هادي سابقا .. وهو عمل مدهش وشامل فعلا .. وأذكر أنني عدلت عليه قليلا ليعطيني الكود الخاص بمنشيء التعبير  أيضا :

الأصل                                                                                                                                     
      

 

المعدل

 

وهذه هي قائمة الخيارات توسعت لطالبها 🙂