اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

دالة ( تفقيط ) تحويل الرقم الى نص بالعربي - طول الرقم غير محدود

عبدالله باقشير

بواسطه عبدالله باقشير
في منتدى الاكسيل Excel

 مشاركة

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

عبدالله باقشير

عبدالله باقشير

قام بنشر
قام بنشر

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

كل عام وانتم بخير

اطلب المسامحة ممن راسلني ولم يجد رد مني

هديتي لكم بعد هذه الغيبة
  


Option Explicit
'========================================================"
'				بسم الله الرحمن الرحيم					 "
'========================================================"
'	  (دالة تحويل الرقم الى نص باللغة العربية (تفقيط	  "
'					 kh_TextNum						 "
'========================================================"
'Num					 الرقم						   "
'========================================================"
'sex				   جنس العملة						"
'FALSE			( فارغ او صفر مذكر  )				  "
'TRUE		  (  أو اي رقم غير الصفر مؤنث )			  "
'========================================================"
'sNameCurr	   اسم العملة الرئيسية مفرد				"
'pNameCurr		 اسم العملة الرئيسية جمع				"
'NameCurrDec		   اسم العملة الكسرية				"
'Decimal_Count  طول الكسر افتراضـياً : بدون اظهار الكسر	"
'==============================================================================================================================================="
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"
'==============================================================================================================================================="
'					   ملاحظات
'  (اولاً : العملة الرئيسية  مثنى (يقوم بها الكود تلقائيا
'	 مع ملاحظة اذا اسم العملة ينتهي بالتاء المربوطة
'			  يجب ان يكتب كذلك وليس بالهاء
'				-----------------------
'	  ثانياً : اذا كانت العملة الرئيسية مفرد فارغاً تعتبر
'		 اسماء العملات (الجمع والكسري) فارغة تلقائيا
'				-----------------------
'ثالثاً : الكلمة الابتدائية بامكانك تغييرها او تجعلها فارغة
Private Const MyBegTx As String = "فقط "  ' ""
'				-----------------------
' MyTNum  رابعا : يمكنك التغيير (اضافة,حذف,تحرير) في الثابت
'			 للفئات الصفرية للرقم ادناه
Private Const MyTNum As String = "ألف-آلاف/مليون-ملايين/مليار-مليارات/بليون-بلايين/بليار-بليارات/ترليون-ترليونات/تريليار-تريليارات/كدرليون-كدرليونات"
'==============================================================================================================================================="
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"
'==============================================================================================================================================="

Function kh_TextNum(Num As String, Optional sex As Boolean = False, Optional sNameCurr As String = "", Optional pNameCurr As String = "", Optional NameCurrDec As String = "", Optional Decimal_Count As Byte = 2) As String
Dim Spp, zt
Dim i%, ii%, pr%
Dim MyMid$, nCurr$, Txt$, Txt1$, Txt2$
'======================================
If Not IsNumeric(Num) Then GoTo kh_Exit
Spp = Split("/" & MyTNum, "/")
ii = UBound(Spp)
If Num < 0 Then Num = Abs(Num)
'======================================
If Val(Num) > Val(String((ii + 1) * 3, "9") & ".999") Then GoTo kh_Exit
'======================================
nCurr = sNameCurr & "-" & IIf(pNameCurr = "", sNameCurr, IIf(sNameCurr = "", "", pNameCurr))
'======================================
Txt1 = Format(Num, String((ii + 1) * 3, "0") & ".000")
For i = 0 To ii
	MyMid = Mid(Txt1, (i * 3) + 1, 3)
	If MyMid Then
		zt = Mid(Txt1, (i * 3) + 4, Len(Txt1))
		zt = IIf(ii - i, Int(zt), zt)
		Txt2 = IIf(ii - i, Trim(Spp(ii - i)), nCurr)
		pr = 1 + IIf(ii - i, 1, CInt(sex))
		Txt = Txt & IIf(Len(Txt), " و", "") & kh_nText(MyMid, Txt2, pr, zt, CBool(sNameCurr <> ""))
	End If
	If i = ii Then If MyMid = 0 Then Txt = Txt & IIf(Len(Txt), " ", "صفر ") & sNameCurr
Next
'======================================
Txt = MyBegTx & Txt & kh_dText(Num, sNameCurr, NameCurrDec, Decimal_Count)
'======================================
kh_Exit:
kh_TextNum = Trim(Txt)
End Function



'	معالجة العدد من 1 الى 999   لكل فئات الرقم
Private Function kh_nText(ByVal iNum As String, ByVal oMm As String, ByVal ibs As Integer, ByVal z As Boolean, ByVal tCu As Boolean) As String
Dim Sp
Dim Num1%, Num2%, Num3%
Dim oM$, S$, S1$, nT$, nT0$, nT1$, nT2$
'======================================
Sp = Split("واحد,إحدى,اثنتان,ثلاث,أربع,خمس,ست,سبع,ثمان,تسع,عشر,إحدى ,اثنتا ", ",")
'======================================
If ibs Then S = "ة": Sp(1) = Sp(0): Sp(2) = "اثنان": Sp(11) = "أحد ": Sp(12) = "اثنا " Else S1 = "ة"
oM = Trim(Split(oMm, "-")(0))
'======================================
Num1 = Left(iNum, 1)
Num2 = Right(iNum, 2)
Select Case Num1
	Case 1:	  nT0 = "مائة"
	Case 2:	  nT0 = "مائتا" & IIf(ibs = 2, IIf(Num2 < 3, "", "ن"), IIf(Num2 = 0 And oM <> "", "", "ن"))
	Case 3 To 9: nT0 = Sp(Num1) & "مائة"
End Select
'=========================================
Num1 = Right(iNum, 2)
Select Case Num1
	Case 1, 2:	 If nT0 <> "" Then If ibs = 2 Then nT0 = nT0 & " " & oM
	Case 11 To 99: If oM <> "" Then If ibs Then If z Then oM = oM & "اً"
End Select
'-----------------------------------------
Select Case Num1
	Case 1
		nT = IIf(oM = "", Sp(0) & S1, oM)
		oM = IIf(ibs <> 2 And oM <> "", Sp(0) & S1, "")
	Case 2
		nT = IIf(oM = "", Sp(Num1), Replace(oM, "ة", "ت") & IIf(z = 0 And ibs = 2 And tCu, "ا", "ان"))
		oM = IIf(ibs <> 2 And oM <> "", Sp(Num1), "")
	Case 3 To 10
		oM = Trim(Split(oMm, "-")(1))
		nT = Sp(Num1) & S
	Case 11, 12
		nT = Sp(Num1) & Sp(10) & S1
	Case 13 To 19
		nT = Sp(Num1 - 10) & S & " " & Sp(10) & S1
	Case 20 To 99
		Num2 = Right(Num1, 1)
		Num3 = Left(Num1, 1)
		If Num3 = 2 Then nT1 = "عشرون" Else nT1 = Sp(Num3) & "ون"
		nT2 = Sp(Num2) & IIf(Num2 > 2, S, "") & " و" & nT1
		If Num2 = 0 Then nT2 = nT1
		nT = nT2
End Select
'======================================
S = IIf(nT = "" Or iNum < 100, "", " و")
nT = Replace(nT, Sp(8) & "ة", Sp(8) & "ية")
kh_nText = Trim(nT0 & S & nT & " " & oM)
'======================================
End Function


'			معالجة الكسر
Private Function kh_dText(ByVal dNum As String, ByVal NCur As String, ByVal Ndec As String, ByVal co As Byte) As String
Dim Td$, Td1$
On Error GoTo 1
If NCur = "" Then Ndec = ""
Td = Format(Round(CCur(dNum - Int(dNum)), co), "0." & String(co, "0"))
If Td = 0 Or Td = 1 Then Td1 = "": GoTo 1
If Len(Ndec) Then Ndec = " " & Ndec: Td1 = Td * CVar("1" & String(co, "0")) Else Ndec = " " & NCur: Td1 = Td
Td1 = "  و " & Chr(40) & Td1 & Chr(41) & Ndec
1: kh_dText = Td1
End Function

دالة تحويل الرقم الى نص عربي.rar

=================================================
الملف المعدل:
هذا المرفق بامكانية تفقيط الكسر
وامكانية ادخال كلمة نهاية النص
دالة تحويل الرقم الى نص عربي.rar
=================================================
رابط مباشر للملف

 

G.png

  • Like 26
  • Thanks 4
  • الردود 77
  • Created
  • اخر رد

Top Posters In This Topic

Popular Days

Top Posters In This Topic

Popular Days

Popular Posts

عبدالله باقشير
عبدالله باقشير

السلام عليكم ورحمة الله وبركاته كل عام وانتم بخير اطلب المسامحة ممن راسلني ولم يجد رد مني هديتي لكم بعد هذه الغيبة   Option Explicit '============================================

عبدالله باقشير
عبدالله باقشير

السلام عليكم ورحمة الله وبركاته الاخ الحبيب/ azeem ______حفظه الله جزاك الله خيرا وبارك الله فيك الاخ الحبيب/ الجزيرة______حفظه الله المنتدى منور بشخصك الكريم رجاءك مقبول جزاك الله

azeem1970
azeem1970

شكرا جزيلا وجعلها الله فى ميزان حسناتك ان شاء الله

Posted Images

الجزيرة

الجزيرة

قام بنشر
قام بنشر

حياك الله أخي الكريم / عبد الله

نورت المنتدى بوجودك

ولكن لنا رجاء ، بأن لا تغيب مره أخرى وإن كان ولا بد فيا حبذا لو تطمئنا عن حالك من وقت لآخر :)

من ناحية الملف فهو بدون شك قمة من القمم

أخوك / أبو عبد الله

أبوعبد الله

أبوعبد الله

قام بنشر
قام بنشر

أخي الحبيب وأستاذنا الفاضل / عبدالله - خبور خير

أشرقت الأنوار ونورت المنتدى وسلمت يداك على الإبداعات التي هي صفة ملازمة لكل مشاركاتك ، أسأل الله أن تكون بكل خير ، ولا تحرمنا من الاطمئنان عليك كلما سمحت ظروفك .

تقلل تحياتي وتقديري وامتناني

اخوك ابو عبدالله

saad abed

saad abed

قام بنشر
قام بنشر

اخى عبدالله ( ابا على )

عودا حميدا نسال الله ان تكون باحسن حال

دالة قيمة لا غنى عن التفقيط للمحاسبين

تحياتى

سعد عابد

أ / محمد صالح

أ / محمد صالح

قام بنشر
قام بنشر

مرحبا بك مرة أخرى أخي خبور خير

لا حرمنا الله منك

وجعل الله اليمن بيديكم أفضل مما كان عليه

هدية مقبولة

وحبذا لو تم تفقيط الكسر أيضا

الـعيدروس

الـعيدروس

قام بنشر
قام بنشر

السلام عليكم

عوداً حميداً ايها الفذ السخي بعطياك استاذ خبور خير

وفقك الله وجعل هذا العمل في ميزان حسناتك

وخلينا نشوفك في ثنايا الصرح الجميل

تقبل مروري

معتصم محمد

معتصم محمد

قام بنشر
قام بنشر

حمداً لله على السلامة استاذنا الفاضل

كل عام وانتم بخير

والكود طبعاً مش هنقدر نقول عليهحاجة، بس حنتعلم منه حاجات كتير

شكراً على هذه الهدية استاذ / عبدالله

أبو سجده

أبو سجده

قام بنشر
قام بنشر

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

أخى الكريم / خبور خير .... كل عام انتم بخير

أسم على مسمى .... لقدأتى الخير من خير

عاشت يداكم الكريمة ... وعاشت اليمن حرة برجالها

فضل حسين

فضل حسين

قام بنشر
قام بنشر

الباشا الكبير / خبور خير باشا

افتقدناك فتره ليست قصيرة والحمد لله رجعت لنا . بارك الله فيك ودائما تكون معانا معلم ومعطاء دائما

كل عام وسيادتكم بخير ويارب تكون بصحة جيدة .

ودائما تكون دائما معنا ومعك .

الشهابي

الشهابي

قام بنشر
قام بنشر

لا تدري بمقدار فرحتنا بعودتك إلينا أخونا واستاذنا أبو علي - خبور خير

إن شاء الله لا تغيب عنا وخاصة هذه الأيام ونرجو مشاركتك في دورة الفيجوال بيسك للتطبيقات

إن شاء الله جئت وجاء الخير يا خبور خير

naderwatfa

naderwatfa

قام بنشر
قام بنشر

نورت المنتدى من جديد أستاذنا الحبيب

خبور خير

ملف رائع

و فيه إمكانيات مرنة و مفيدة

هوه ده الشغل

رجائي ما تطولش الغياب عننا تاني

ريان أحمد

ريان أحمد

قام بنشر
قام بنشر

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

الحسامي

الحسامي

قام بنشر
قام بنشر

عودة النسر ماشاء الله

حفظك الله ورعاك وحفظ أهل اليمن الكرام

دالة اقل ما توصف بانها خرافية

بارك الله فيك

دغيدى

دغيدى

قام بنشر
قام بنشر (معدل)

أخى الفاضل / خبور خير

سلام الله على أهلنا فى اليمن السعيد الشقيق

لما هذه الغيبة الطويلة

اخى ..تمييز الأعداد المركبة والعقود تكون مفردا منصوبا : 15 جنيها ... 20 جنيها

لما لا والحل فى جعبتكم

تم تعديل بواسطه دغيدى
  • Like 1
عبدالله باقشير

عبدالله باقشير

قام بنشر
  • الكاتب
قام بنشر

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

الاخ الحبيب/ azeem ______حفظه الله

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

الاخ الحبيب/ الجزيرة______حفظه الله

المنتدى منور بشخصك الكريم

رجاءك مقبول

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

الاخ الحبيب/ عبدالله المجرب______حفظه الله

المنتدى منور بشخصك الكريم

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

الاخ الحبيب/ ابوعبدالله______حفظه الله

المنتدى منور بشخصك الكريم

هذا العمل من ثمرة العمل السابق الذي لك باع كبير في انجازه

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

الاخ الحبيب/ سعد عابد______حفظه الله

نعم صدقت

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

الاخ الحبيب/ محمد صالح ______حفظه الله

تدعوا الله ان يمن علينا وعليكم وعلى جميع المسلمين بالامن والامان

وحبذا لو تم تفقيط الكسر أيضا

تم التنفيذ في الملف المرفق

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

الاخ الحبيب/ alidroos______حفظه الله

الله يكرمك في الدارين

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

الاخ الحبيب/ معتصم محمد______حفظه الله

شكرا جزيلا والغاية من وضع اي عمل هو طرح افكاروطرق مختلفة

وانا مستعد لشرح اي جزئية غامضة

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

الاخ الحبيب/ سعيد______حفظه الله

الله يكرمك في الدارين

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

الاخ الحبيب/ يحياوي______حفظه الله

الله يكرمك في الدارين

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

الاخ الحبيب/ فضل 1______حفظه الله

الله يكرمك في الدارين

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

الاخ الحبيب/ الشهابي______حفظه الله

الله يكرمك في الدارين

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

الاخ الحبيب/نادر______حفظه الله

الله يكرمك في الدارين ورجاءك مقبول

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

الاخ الحبيب/ محمدي______حفظه الله

الله يكرمك في الدارين

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

الاخ الحبيب/ طاهر______حفظه الله

الله يكرمك في الدارين

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

الاخ الحبيب/الحسامي______حفظه الله

الله يكرمك في الدارين

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

الاخ الحبيب/دغيدي______حفظه الله

شاهد التعديل في المرفق

واي ملاحظات اشعرنا بها

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

=========================================================================

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




Option Explicit


'========================================================"

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

'========================================================"

'	  (دالة تحويل الرقم الى نص باللغة العربية (تفقيط	  "

'					 kh_TextNum						 "

'========================================================"

'Num					 الرقم						   "

'========================================================"

'Sex				   جنس العملة						"

'		FALSE   ( أو فارغ او صفر مذكر )				 "

'		TRUE   (  أو اي رقم غير الصفر مؤنث )			 "

'========================================================"

'NCurr_Si		اسم العملة الرئيسية مفرد				"

'NCurr_Pl		  اسم العملة الرئيسية جمع				"

'NCurrDec_Si		   اسم العملة الكسرية				"

'Decimal_Count  طول الكسر افتراضـياً : بدون اظهار الكسر	"

'========================================================"

'			: للدلالة على تفقيط الكسر عين التالي			"

'NCurrDec_pl	   اسم العملة الكسرية جمع				 "

'dSex			   جنس عملة الكسر					   "

'		FALSE   ( أو فارغ او صفر مذكر )				 "

'		TRUE   (  أو اي رقم غير الصفر مؤنث )			 "

'========================================================"

'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"

'					   ملاحظات

'  (اولاً : العملة الرئيسية  مثنى (يقوم بها الكود تلقائيا

'	 مع ملاحظة اذا اسم العملة ينتهي بالتاء المربوطة

'			  يجب ان يكتب كذلك وليس بالهاء

'				-----------------------

'	  ثانياً : اذا كانت العملة الرئيسية مفرد فارغاً تعتبر

'		 اسماء العملات (الجمع والكسري) فارغة تلقائيا

'				-----------------------

'("" ثالثاً : امكانية إضافة كلمة بداية ونهاية النص (فارغة

Private Const MyBegTx As String = "فقط "

Private Const MyEndTx As String = ""

'				-----------------------

' MyTNum  رابعا : يمكنك التغيير (اضافة,حذف,تحرير) في الثابت

'			 للفئات الصفرية للرقم ادناه

Private Const MyTNum As String = "ألف-آلاف/مليون-ملايين/مليار-مليارات/بليون-بلايين/بليار-بليارات/ترليون-ترليونات/تريليار-تريليارات/كدرليون-كدرليونات"

'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"

'==============================================================================================================================================="

Private Const wow As String * 2 = " و"

'==============================================================================================================================================="


Function kh_TextNum(Num As String, Optional Sex As Boolean = False _

		, Optional NCurr_Si As String = "", Optional NCurr_Pl As String = "" _

		, Optional NCurrDec_Si As String = "", Optional Decimal_Count As Byte = 0 _

		, Optional NCurrDec_Pl As String = "", Optional dSex As Boolean = False) As String

'======================================

Dim Spp, zt

Dim i%, ii%, pr%

Dim MyMid$, nCurr$, Txt$, Txt1$, Txt2$

'======================================

If Not IsNumeric(Num) Then GoTo kh_Exit

If Num = 0 Then Txt = MyBegTx & "صفر " & NCurr_Si: GoTo kh_Exit

'======================================

Spp = Split("/" & MyTNum, "/")

ii = UBound(Spp)

If Num < 0 Then Num = Abs(Num)

'======================================

If Val(Num) > Val(String((ii + 1) * 3, "9") & ".999") Then GoTo kh_Exit

'======================================

nCurr = NCurr_Si & "-" & IIf(NCurr_Pl = "", NCurr_Si, IIf(NCurr_Si = "", "", NCurr_Pl))

'======================================

Txt1 = Format(Num, String((ii + 1) * 3, "0") & ".000")

For i = 0 To ii

	MyMid = Mid(Txt1, (i * 3) + 1, 3)

	If MyMid Then

		zt = Mid(Txt1, (i * 3) + 4, Len(Txt1))

		zt = IIf(ii - i, Int(zt), 1)

		Txt2 = IIf(ii - i, Trim(Spp(ii - i)), nCurr)

		pr = 1 + IIf(ii - i, 1, CInt(Sex))

		Txt = Txt & IIf(Len(Txt), wow, "") & kh_nText(MyMid, Txt2, pr, zt, CBool(NCurr_Si <> ""))

	End If

	If i = ii Then If MyMid = 0 Then Txt = Txt & IIf(Len(Txt), " " & NCurr_Si, IIf(Decimal_Count = 0, "صفر", ""))

Next

'======================================

Txt = MyBegTx & Txt & kh_dText(Num, NCurr_Si, Trim(NCurrDec_Si), Decimal_Count, Trim(NCurrDec_Pl), dSex) & MyEndTx

'======================================

kh_Exit:

kh_TextNum = Trim(Txt)

End Function



'	معالجة العدد من 1 الى 999   لكل فئات الرقم

Private Function kh_nText(ByVal iNum As String, ByVal oMm As String, ByVal ibs As Integer, ByVal Z As Boolean, ByVal tCu As Boolean) As String

Dim Sp

Dim Num1%, Num2%, Num3%

Dim oM$, S$, S1$, nT$, nT0$, nT1$, nT2$

'======================================

Sp = Split("واحد,إحدى,اثنتان,ثلاث,أربع,خمس,ست,سبع,ثمان,تسع,عشر,إحدى ,اثنتا ", ",")

'======================================

If ibs Then S = "ة": Sp(1) = Sp(0): Sp(2) = "اثنان": Sp(11) = "أحد ": Sp(12) = "اثنا " Else S1 = "ة"

oM = Trim(Split(oMm, "-")(0))

'======================================

Num1 = Left(iNum, 1)

Num2 = Right(iNum, 2)

Select Case Num1

	Case 1:	  nT0 = "مائة"

	Case 2:	  nT0 = "مائتا" & IIf(ibs = 2, IIf(Num2 < 3, "", "ن"), IIf(Num2 = 0 And oM <> "", "", "ن"))

	Case 3 To 9: nT0 = Sp(Num1) & "مائة"

End Select

'=========================================

Num1 = Right(iNum, 2)

Select Case Num1

	Case 1, 2:	 If nT0 <> "" Then If ibs = 2 Then nT0 = nT0 & " " & oM

	Case 11 To 99: If oM <> "" Then If ibs Then If Z Then oM = oM & "اً"

End Select

'-----------------------------------------

Select Case Num1

	Case 1

		nT = IIf(oM = "", Sp(0) & S1, oM)

		oM = IIf(ibs <> 2 And oM <> "", Sp(0) & S1, "")

	Case 2

		nT = IIf(oM = "", Sp(Num1), Replace(oM, "ة", "ت") & IIf(Z = 0 And ibs = 2 And tCu, "ا", "ان"))

		oM = IIf(ibs <> 2 And oM <> "", Sp(Num1), "")

	Case 3 To 10

		oM = Trim(Split(oMm, "-")(1))

		nT = Sp(Num1) & S

	Case 11, 12

		nT = Sp(Num1) & Sp(10) & S1

	Case 13 To 19

		nT = Sp(Num1 - 10) & S & " " & Sp(10) & S1

	Case 20 To 99

		Num2 = Right(Num1, 1)

		Num3 = Left(Num1, 1)

		If Num3 = 2 Then nT1 = "عشرون" Else nT1 = Sp(Num3) & "ون"

		nT2 = Sp(Num2) & IIf(Num2 > 2, S, "") & wow & nT1

		If Num2 = 0 Then nT2 = nT1

		nT = nT2

End Select

'======================================

S = IIf(nT = "" Or iNum < 100, "", wow)

nT = Replace(nT, Sp(8) & "ة", Sp(8) & "ية")

kh_nText = Trim(nT0 & S & nT & " " & oM)

'======================================

End Function



'			معالجة الكسر

Private Function kh_dText(ByVal dNum As String, ByVal NCur As String, ByVal Ndec As String, ByVal co As Byte, ByVal Ndec_pl As String, ByVal dsx As Boolean) As String

Dim Td$, dwow$, Td1$

On Error GoTo 1

If co = 0 Then GoTo 1

If NCur = "" Then Ndec = ""

Td = Format(Round(CCur(dNum - Int(dNum)), co), "0." & String(co, "0"))

If Td = 0 Or Td = 1 Then Td1 = "": GoTo 1

If Int(dNum) Then dwow = wow

If Len(Ndec) Then

	Ndec = " " & Ndec

	Td1 = Td * CVar("1" & String(co, "0"))

	If Len(Ndec_pl) And co < 4 Then Td1 = dwow & kh_nText(Format(Td1, "000"), Ndec & "-" & Ndec_pl, 1 + CInt(dsx), 1, 0): GoTo 1

Else

	Ndec = " " & NCur: Td1 = Td

End If

Td1 = dwow & " " & Chr(40) & Td1 & Chr(41) & Ndec

1: kh_dText = Td1

End Function

دالة تحويل الرقم الى نص عربي.rar

  • Thanks 2
أ / محمد صالح

أ / محمد صالح

قام بنشر
قام بنشر

بارك الله لك أخي خبور خير

جعل الله الخير حيث كنت

يكتمل العمل الرائع ب

  • تفقيط الكسر ضمن الدالة
  • وعدم قصور الكسر على رقمين فقط بل تظل مفتوحة حتى لو إلى 18 رقم

فهلا تفضلت على إخوانك بها

تقبل مروري وتحياتي على هذا الكود الرائع حقاً

السيد عبد الفتاح

السيد عبد الفتاح

قام بنشر
قام بنشر

عوداً حميدا وطولا مديداً أستاذنا الفاضل

والله لقد اشتقنا اليك وطال انتظارنا الى تحفك وروائعك

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

اخوكم / السيد عبد الفتاح

عبدالله باقشير

عبدالله باقشير

قام بنشر
  • الكاتب
قام بنشر

السلام عليكم

الاخ الفاضل/ محمد صالح ______حفظه الله

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

يكتمل العمل الرائع ب
  • تفقيط الكسر ضمن الدالة
  • وعدم قصور الكسر على رقمين فقط بل تظل مفتوحة حتى لو إلى 18 رقم

يتم تفقيط الكسر لطول 3 ارقام وليس 2

لاني اعتقد ان الكسر للعملة لا يزيد على 3 ارقام

والله اعلم

عفوا على هذا السؤال

في ماذا تحتاج لتفقيط كسر الى بطول 18 رقم ؟

هل يستخدم في تفقيط شي آخر غير العملات ؟

بالنسبة للطلب

ان شاء الله

ممكن القيام به فقط يحتاج الى دالة رئيسية اخرى

تتعامل مع هذه الدالة على شقين

مرة للرقم الصحيح واخرى للكسر

وربط النتائج مع بعض.

اخبرني اذا كان هناك احتياج لها ساقوم بالعمل

تقبل تحياتي وشكري

  • Like 1
زائر
هذا الموضوع مغلق.
 مشاركة
الذهاب الي قائمه المواضيع


×
×
  • اضف...

Important Information

  I accept