Moosak قام بنشر منذ 23 ساعات قام بنشر منذ 23 ساعات السلام عليكم ورحمة الله وبركاته .. 🙂 نزولا عند رغبة شيخنا الفاضل @ابوخليل تم إضافة تحسين بسيط على دالة التفقيط المبسطة لتعميم الفائدة .. طبعا الدالة كانت تأخذ 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 2 2
منتصر الانسي قام بنشر منذ 1 ساعه قام بنشر منذ 1 ساعه عمل رائع أخي @Moosak وإثراءً للموضوع أرفق لكم مثالين الاول للأستاذ الغالي @عبدالله باقشير الله يذكره بالخير (كان مشرفاً لمنتدى أكسل وكان إسمه في المنتدى خبور خير) حيث أنه قد قام بتغطية كل ماجاء في هذا المثال مع إضافة بعض الإضافات الجميلة التي يمكن أن يراها البعض مهمة ولعل أهمها - طريقة كتابة إسم العملة للأرقام من 3 إلى 10 (مثال خمسة ريالات وليس خمسة ريال) - إمكانية تفقيط رقم يصل إلى البلايين (مايزيد عن 999 مليار) المثال الآخر للأستاذ الكبير أبو هادي (لن يعرفه إلا القدامى 😅) ويشبه مثال الاخ عبدالله كثيراً ولكنه يتميز عنه بأنه ثنائي اللغة فيمكنك التفقيط باللغتين العربية والإنجليزية فلو أمكنك أستاذ موسى الإطلاع على المثالين لترى إذا ماكان بإمكانك إضافة الخيارات الإضافية التي وردت فيها لتخرج بعمل أكثر تكاملاً أمثلة للتفقيط.rar 1
شايب قام بنشر منذ 1 ساعه قام بنشر منذ 1 ساعه (معدل) 52 دقائق مضت, منتصر الانسي said: - طريقة كتابة إسم العملة للأرقام من 3 إلى 10 (مثال خمسة ريالات وليس خمسة ريال) تمييز الاعداد من 3 الى 10 يكون جمع مجرور بالاضافة ويخالف العدد المعدود في التذكير والتانيث خمسة ريالات الريال مذكر فتكتب خمسة كما اشار الاستاذ منتصر خمس ليرات ليرة مؤنتة تأنيث لفضي فيكتب العدد خمس الاعداد 1 و 2 يوافق العدد المعدود تذكيرا وتانيثا ويسبق المعدود العدد رجل واحد سيارة واحدة العدد 2 يعرب اعراب المثنى فيرفع بالالف وينصب ويجر بالياء العدد 11 و 12 يطابق العدد المعدود وتمييزهما مفرد منصوب العدد 11 يبنى على فتح الجزاين و12 يعرب اعراب المثنى الاعداد 13 - 19 يخالف الجزء الأول من العدد المعدود والجزء الثاني يطابقه في التذكير والتانيث والتميز مفرد منصوب والعدد مبني على فتح الجزاين حضر خمسة عشر طالبا نجحت ثلاث عشرة طالبة الفاض العقود تعرب اعراب جمع المذكر فترفع بالواو وتنصب وتجر بالياء وتمييزها مفرد منصوب ولا تتاثر بالتأنيث والتذكير قرأتُ عشرينَ كتاباً شاهدت عشرين طالبا مررت بعشرين طالبا الاعداد 100 و 1000 و الخ تمييزها مفرد مجرور بالاضافة لماذا هذه المشاركة ربما ينتفع بها احدهم املاه اخونا الشايب تم تعديل منذ 49 دقائق بواسطه شايب
الردود الموصى بها
انشئ حساب جديد او قم بتسجيل دخولك لتتمكن من اضافه تعليق جديد
يجب ان تكون عضوا لدينا لتتمكن من التعليق
انشئ حساب جديد
سجل حسابك الجديد لدينا في الموقع بمنتهي السهوله .
سجل حساب جديدتسجيل دخول
هل تمتلك حساب بالفعل ؟ سجل دخولك من هنا.
سجل دخولك الان