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

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

Recommended Posts

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

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

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

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


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 23
  • Thanks 1

شارك هذه المشاركه


رابط المشاركه
شارك

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

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

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

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

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

شارك هذه المشاركه


رابط المشاركه
شارك

جاءت متاخر

يادا النور يا دا النور

هدية السنة الهجرية

مرحباً بعودتك ابا علي

==

تم التثبيت لعموم الفائدة

شارك هذه المشاركه


رابط المشاركه
شارك

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

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

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

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

شارك هذه المشاركه


رابط المشاركه
شارك

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

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

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

تحياتى

سعد عابد

شارك هذه المشاركه


رابط المشاركه
شارك

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

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

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

هدية مقبولة

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

شارك هذه المشاركه


رابط المشاركه
شارك

السلام عليكم

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

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

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

تقبل مروري

شارك هذه المشاركه


رابط المشاركه
شارك

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

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

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

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

شارك هذه المشاركه


رابط المشاركه
شارك

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

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

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

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

شارك هذه المشاركه


رابط المشاركه
شارك

الاستاذ الفاضل و الاخ الحبيب "خبور" عودا حميدا ان شاء الله و كل عام وانت بالف خير

هدية رائعة و قيمة بارك الله فيك الله يوفقك

شارك هذه المشاركه


رابط المشاركه
شارك

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

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

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

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

شارك هذه المشاركه


رابط المشاركه
شارك

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

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

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

شارك هذه المشاركه


رابط المشاركه
شارك

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

خبور خير

ملف رائع

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

هوه ده الشغل

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

شارك هذه المشاركه


رابط المشاركه
شارك

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

شارك هذه المشاركه


رابط المشاركه
شارك

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

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

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

بارك الله فيك

شارك هذه المشاركه


رابط المشاركه
شارك

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

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

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

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

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

تم تعديل بواسطه دغيدى

شارك هذه المشاركه


رابط المشاركه
شارك

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

الاخ الحبيب/ 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

شارك هذه المشاركه


رابط المشاركه
شارك

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

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

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

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

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

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

شارك هذه المشاركه


رابط المشاركه
شارك

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

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

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

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

شارك هذه المشاركه


رابط المشاركه
شارك

السلام عليكم

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

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

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

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

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

والله اعلم

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

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

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

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

ان شاء الله

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

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

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

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

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

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

شارك هذه المشاركه


رابط المشاركه
شارك

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.


  • محتوي مشابه

    • بواسطه scorpion4ever
      أخي الكريم المسألة بسيطة جداً فقط اتبع الخطوات ولا تهمل منها شيء
      1-حمل الملفات المرفقة بالمقال والموضوعة بملف مضغوط وبعد فك الضغط ينتج لك الملفين التاليين Module1 و NewMacros
      2-افتح وورد ومن قائمة أدوات اختر : ماكرو > محرر Visual Basic
      3-من قائمة File اختر Import file ثم اختر الملفات التي قمت بتحميلها من المرفق
      4-اغلق صفحة Visual Basic وارجع لصفحة وورد
      5-من قائمة عرض اختر أشرطة أدوات > تخصيص ، ومن التبويب الأوامر وتحت قائمة فئات اختر وحدات ماكرو لتظهر فى القائمة المقابلة أمر Normal.NewMacros.تفقيط واضغط علية بالماوس مع السحب إلى شريط القوائم أو أي مجموعة من الأزرار
      6-يمكنك تعديل الاسم والخواص بالضغط بالزر الأيمن على الأمر الجديد وذلك قبل غلق مربع حوار تخصيص
      7-اكتب أي رقم مرغوب في وورد ثم حدده وهذه النقطة مهمة " التحديد" ثم اكبس الزر أز الأمر الذي أنتجته فيظهر التفقيط فوراً
      8- لتغيير الليرة السورية والقرش افتح وورد ومن قائمة أدوات اختر : ماكرو > محرر Visual Basic ثم اتجه لمجموعة النورمال Normal > ومنها Modules ثم افتح المسمى New Macros فتجد نوع العملة قم بتغييرها من هنا
      نجاح العملية معك يعتبر نجاح لي ولك على السواء
      scorpion4ever
      المرفق
      Tafqeet.rar
    • بواسطه عبدالله بن عبدالعزيز
      السلام عليكم ورحمة الله وبركاته
       
      اخواني عندي هالنموذج عملته بطريقه بدائيه للطباعه على الشيكات
      والحمدلله يخدمني ولكن عندي مشكله في التفقيط اكتبه يدويا
      فكيف الطريقه ليقرأ الرقم ويكتبه في الخانه المطلوبه بدون تدخل مني
       
      وجزاكم الله خيرا
       
      مرفق النموذج
      نموذج شيكات.rar
    • بواسطه Friendly
      اسعد الله أوقاتكم،
      قمت بنسخ نص من احد المواقع وقمت بلصقه في برنامج Microsoft word 2010، الا ان الأرقام ظهرت باللغة الانكليزية (العربية لغة البرنامج) والمطلوب تحويلها الى اللغة العربية ( الهندية). علما بان إعدادات اللغة صحيحة في خيارات الوورد، الا ان المشكلة في أصل النص المنسوخ.
      هل بالإمكان انشاء كود لتحويل الأرقام من اللغة العربية الى اللغة الهندية:
      من 1,2,3,4,5,6 الى ١،٢،٣،٤،٥،٦
      أرجو ان ألقى ضالتي لديكم خصوصا انني منذ فترة وانا ابحث ولم استطع.
      وشكرا لكم سلفا
    • بواسطه الحامد الشاكر
      السلام عليكم ورحمة اله وبركاته
      يرجى توضيح طريقة إدراج معادلة للتفقيط في ملف وورد
      بحيث يتم وضع الرقم وعند تنفيذ الكود يتم التفقيط تلقائياً له
      والكود مرفق في الملف المرفق
      مع التحية
      تفقيط إكسيل إنكليزي.rar
    • بواسطه ma0fd2010
      التفقيط وتحويل الارقام إلى حروف بالعربية في اكسل
       
      أخواني الأعزاء اقدم لكم ملف اكسل يحتوي على ماكرو تفقيط الارقام باللغة العربية 
      https://youtu.be/yzDZmVH8WuM
       
  • المتواجدين الان   0 اعضاء متواجدين الان

    لايوجد اعضاء مسجلون يتصفحون هذه الصفحه

×
×
  • اضف...