السلام عليكم ورحمة الله وبركاته
كود:
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
الملف المعدل:
هذا المرفق بامكانية تفقيط الكسر
وامكانية ادخال كلمة نهاية النص
هذا المرفق بامكانية تفقيط الكسر
وامكانية ادخال كلمة نهاية النص
