تفقيط العملة بالوورد

[hat]

هذا الماكرو يحول الارقام الى عملة بالريال السعودي ويمكنك تغيير العملة في اول الكود لأي عملة تريدها

 

Sub num2text()
'

'
'
    Selection.HomeKey Unit:=wdLine
    Selection.EndKey Unit:=wdLine, Extend:=wdExtend
    Selection = word(Selection)
    
End Sub
                
  


Public Function word(x)
On Error Resume Next


ra = " ريالاً "
ha = " هللة "
n = Int(x)
b = Val(Right(Format(x, "000000000000000.00"), 2))
r = aword(n)
b1 = aword(b)

If b >= 3 And b <= 10 Then ha = " هللات "
If Right(n, 1) >= 3 And Right(n, 1) <= 10 Then

If Right(n, 2) < 10 Then ra = " ريالات "
End If
If b = 2 Then b1 = " هللتان ": ha = ""
If b = 1 Then b1 = " هللة واحدة ": ha = ""

If n = 1 Then r = "ريال واحد ": ra = ""

If r <> "" And b >= 0 Then Result = " فقط " & r & ra & " و" & b1 & ha & " لا غير ."
If r = "" And b <> 0 Then Result = " فقط " & b1 & ha & "  لا غير "

If r = "" And b = 0 Then Result = ""
If r <> "" And b = 0 Then Result = " فقط " & r & ra & " لا غير . "

word = Result

End Function

Private Function aword(x)
n = Int(x)
c = Format(n, "000000000000000")

c1 = Val(Mid(c, 15, 1))

Select Case c1
Case Is = 1: letr1 = "واحد"
Case Is = 2: letr1 = "إثنان"
Case Is = 3: letr1 = "ثلاثة"
Case Is = 4: letr1 = "أربعة"
Case Is = 5: letr1 = "خمسة"
Case Is = 6: letr1 = "ستة"
Case Is = 7: letr1 = "سبعة"
Case Is = 8: letr1 = "ثمانية"
Case Is = 9: letr1 = "تسعة"
End Select


c2 = Val(Mid(c, 14, 1))
Select Case c2
Case Is = 1: letr2 = "عشر"
Case Is = 2: letr2 = "عشرون"
Case Is = 3: letr2 = "ثلاثون"
Case Is = 4: letr2 = "أربعون"
Case Is = 5: letr2 = "خمسون"
Case Is = 6: letr2 = "ستون"
Case Is = 7: letr2 = "سبعون"
Case Is = 8: letr2 = "ثمانون"
Case Is = 9: letr2 = "تسعون"
End Select

If letr1 <> "" And c2 > 1 Then letr2 = letr1 + " و " + letr2
If letr2 = "" Then letr2 = letr1

If c1 = 0 And c2 = 1 Then letr2 = letr2 + "ة"

If c1 = 1 And c2 = 1 Then letr2 = "إحدى عشر"
If c1 = 2 And c2 = 1 Then letr2 = "إثنا عشر"

'If c1 = 2 And c2 = 0 Then letr2 = "ريالان"

If c1 > 2 And c2 = 1 Then letr2 = letr1 + "  " + letr2


c3 = Val(Mid(c, 13, 1))

Select Case c3
Case Is = 1: letr3 = "مائة"
Case Is = 2: letr3 = "مئتان"

Case Is = 8: letr3 = Left(aword(c3), Len(aword(c3)) - 2) + "مائة"
Case Is > 2: letr3 = Left(aword(c3), Len(aword(c3)) - 1) + "مائة"

End Select

If letr3 <> "" And letr2 <> "" Then letr3 = letr3 + " و " + letr2
If letr3 = "" Then letr3 = letr2

'=====
c4 = Val(Mid(c, 10, 3))

Select Case c4
Case Is = 1: letr4 = " ألف"
Case Is = 2: letr4 = " ألفان"
Case 3 To 10: letr4 = aword(c4) + " آلاف"
Case Is > 10: letr4 = aword(c4) + " ألفاً"

End Select

If letr4 <> "" And letr3 <> "" Then letr4 = letr4 + " و " + letr3

If letr4 = "" Then letr4 = letr3
'=====


c5 = Val(Mid(c, 7, 3))

Select Case c5
Case Is = 1: letr5 = " مليون"
Case Is = 2: letr5 = " مليونان"
Case 3 To 10: letr5 = aword(c5) + " ملايين"
Case Is > 10: letr5 = aword(c5) + " مليوناً"

End Select

If letr5 <> "" And letr4 <> "" Then letr5 = letr5 + " و " + letr4
If letr5 = "" Then letr5 = letr4

'==

c6 = Val(Mid(c, 4, 3))

Select Case c6
Case Is = 1: letr6 = " مليار"
Case Is = 2: letr6 = " ملياران"
Case 3 To 10: letr6 = aword(c6) + " مليارات"
Case Is > 10: letr6 = aword(c6) + " ملياراً"

End Select

If letr6 <> "" And letr5 <> "" Then letr6 = letr6 + " و " + letr5
If letr6 = "" Then letr6 = letr5

'=====

c7 = Val(Mid(c, 1, 3))

Select Case c7
Case Is = 1: letr7 = " ترليون"
Case Is = 2: letr7 = " ترليونان"
Case 3 To 10: letr7 = aword(c7) + " ترليونات"
Case Is > 10: letr7 = aword(c7) + " ترليوناًً"

End Select

If letr7 <> "" And letr6 <> "" Then letr7 = letr7 + " و " + letr6
If letr7 = "" Then letr7 = letr6

aword = letr7


End Function

 

[أبو محمد أشرف]

جزاك الله خيرا أخي الحبيب 

ولكن يا حبذا لو تضع هذا الكود في منتدى الإكسيل

ومرحبا بك بين إخوانك 

[hat]

الأخ الفاضل / أبو محمد أشرف

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

أشكرك يا سيدي على النصيحة ولكن هذا الماكرو للورد وليس لأكسيل لذا لزم التنويه مع

فهو يستخدم مع ملفات وورد فقط وليس اكسيل .

 

 

مع انه يشبه ملفات اكسيل ولكن الفرق في الثلاث  سطور  الاولى التي تتيح اختيار الارقام أما في اكسيل فانت تضع عنوان الخلية وقد ارفقت

 

ماكرو لاكسيل بنفس المعنى ولكنه مختلف . دمت بود

 

اخوكم هاشم احمد طه

[أبو محمد أشرف]

جزاك الله خيرا لو ترفق ملف ورد وبه الكود

[تومي محمد]

بارك الله فيك

[رفعت يسري حامد]

أشكرك أخي الكريم فهذا كود رائع حقًا

جزاك الله عنا كل خير

[رفعت يسري حامد]

سؤال محيرني بالنسبة للمديول والفورم

كيف يتم عمل rename لمديول أو فورم عندي ؟؟؟

[رفعت يسري حامد]

تم حل المشكلة

[أبو محمد عباس]

السلام عليكم

الاخ الكريم جزاك الله خيرا على الكود الرائع

لكن لي سؤال كيف يتعرف الكود على العدد الذي اريد تفقيطه وما هي الية العمل هل هناك معادلة كما في الاكسل ام هناك عمل اخر يختلف

ارجو التفضل بشرح العمل ولكم دعواتي بالموفقية والنجاح

[أبو محمد أشرف]

أضم صوتي إلى أخي عباس

[حمادة عمر]

جزاك الله خيرا

[hat]

بسم الله الرحمن الرحيم

 

الاساتذة / عباس السماوي وأبو محمد أشرف

 

السلام عليكم ورحمة الله وبركاته ، وعلى جميع رواد المنتدى

 

اولا اشكركم جزيل الشكر للردود الكريمة وبعد

بخصوص التعرف على  العدد فهو في الجزء العلوي من الكود هناك

Sub num2text()
'
'
Selection.HomeKey Unit:=wdLine  هنا ينتقل المؤشر الى بداية الرقم 
Selection.EndKey Unit:=wdLine, Extend:=wdExtend وهنا يتم تحديد الرقم بالانتقال الى نهاية العدد
Selection = word(Selection) وهنا يتم وضع التحديد الذي هو العدد في المتغير المحدد  وبعد ذلك يأتي دور  دالة word  التي تحول المتغير الى صيغة كلمات عددية 
 
End Sub
 والملاحظ ان يتم كتابة عدد فقط بدون كلمات لأن التحديد يتم لجميع الجملة  فبعد كتابة الرقم وتحويله الى نص يمكنك اضافة اي بيانات لاحقة

 

ارجو ان اكون قد وفقت بالشرح ودمتم بود

[أبو محمد أشرف]

اريد تطبيق عملي ويا ريت شرح فيديو لذلك

[أبو محمد عباس]

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

اخي العزيز hat جزاك الله خيرا

وانا كذلك اضم صوتي لصوت الاخ العزيز ابو محمد اشرف جزاه الله خيرا

انا بحثت كثيرا على دالة للتفقيط وجدت المرفق وفيه  شرح لكيفية التفقيط وعملت كما في الشرح ولم تفلح معي العملية والشرح هو للاستاذ القدير تومي محمد حفظه الله واعطاه الصحة والعافية

وتقبلوا فائق احترامي وتقديري

 

لتحويل الارقام الى حروفdocx.rar

[hat]

الاخ عباس السماوي 

 

اكتب الرقم ثم اختار المطور من شريط الادوات ثم نفذ الماكرو بكل بساطة