عاوز دالة تفقيط الرقم بالعربي
السلام عليكم،
يُرجى أولا نقل هذا البرنامج الذي في الإطار أسفله :
Option VBASupport 1
Option Explicit
Option Compatible
'========================================================"
' بسم الله الرحمن الرحيم "
'========================================================"
' (دالة تحويل الرقم الى نص باللغة العربية (تفقيط "
' Tafqit "
'========================================================"
'Num الرقم "
'========================================================"
'Gender جنس العملة "
' FALSE ( أو فارغ او صفر مذكر ) "
' TRUE ( أو اي رقم غير الصفر مؤنث ) "
'========================================================"
' NCurr_Si اسم العملة الرئيسة مفرد "
' NCurr_Pl اسم العملة الرئيسة جمع "
' NCurrDec_Si اسم العملة الكسرية "
' : للدلالة على تفقيط الجزء العشري عين التالي "
'NCurrDec_pl اسم العملة الكسرية جمع "
'========================================================"
' Decimal_Count طول الجزء العشري افتراضـياً : بدون اظهار الجزء العشري "
'dGender جنس عملة الجزء العشري "
' FALSE ( أو فارغ او صفر مذكر ) "
' TRUE ( أو اي رقم غير الصفر مؤنث ) "
'========================================================"
'البرنامج الأصلي من إنجاز عبدالله باقشير، وقد تم تعديله ليوافق الاستخدام في ليبرأوفيس "
' كما أضيف له تفقيط العدد السالب
' https://www.officena.net/ib/topic/39447-%D8%AF%D8%A7%D9%84%D8%A9-%D8%AA%D9%81%D9%82%D9%8A%D8%B7-%D8%AA%D8%AD%D9%88%D9%8A%D9%84-%D8%A7%D9%84%D8%B1%D9%82%D9%85-%D8%A7%D9%84%D9%89-%D9%86%D8%B5-%D8%A8%D8%A7%D9%84%D8%B9%D8%B1%D8%A8%D9%8A-%D8%B7%D9%88%D9%84-%D8%A7%D9%84%D8%B1%D9%82%D9%85-%D8%BA%D9%8A%D8%B1-%D9%85%D8%AD%D8%AF%D9%88%D8%AF/
'========================================================"
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"
' ملاحظات
' (اولاً : العملة الرئيسة مثنى (يقوم بها البرنامج تلقائيا
' مع ملاحظة اذا اسم العملة ينتهي بالتاء المربوطة
' يجب ان يكتب كذلك وليس بالهاء
' -----------------------
' ثانياً : اذا كانت العملة الرئيسة مفرد فارغاً تعتبر
' اسماء العملات (الجمع والكسري) فارغة تلقائيا
Private Const MyBegTx As String = ""
Private Const MyEndTx As String = ""
' -----------------------
'MyTNum رابعا : يمكنك التغيير (اضافة,حذف,تحرير) في الثابت
' للفئات الصفرية للرقم ادناه
Private Const MyTNum As String = "ألف-آلاف/مليون-ملايين/مليار-مليارات/بليون-بلايين/بليار-بليارات/ترليون-ترليونات/تريليار-تريليارات/كدرليون-كدرليونات"
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"
'==============================================================="
Private Const wow As String = " و"
Private Const MyNegTx As String = "سالب "
'==============================================================="
Function Tafqit(Num As String, Optional NCurr_Si As String = "", Optional NCurr_Pl As String = "" _
, Optional NCurrDec_Si As String = "", Optional NCurrDec_Pl As String = "", Optional Decimal_Count As Byte = 2 _
, Optional Gender As Boolean = False, Optional dGender As Boolean = False) As String
'======================================
Dim Spp, zt
Dim Neg$ : Neg$ = ""
Dim i%, ii%, pr%
Dim MyMid$, nCurr$, Txt$, Txt1$, Txt2$
'======================================
If Not IsNumeric(Num) Then GoTo kh_Exit
if Num > "99999999999999" Then Txt = "خطأ : تجاوز العدد الحد الأقصى !" : GoTo kh_Exit ' Overflow
If Num = 0 Then Txt = MyBegTx & "صفر " & NCurr_Si: GoTo kh_Exit
'======================================
Spp = Split("/" & MyTNum, "/")
ii = UBound(Spp)
If Num < 0 Then Num = Mid(Num, 2, Len(Num)): Neg$ = MyNegTx
'======================================
If Val(Num) > Val(String((ii + 1) * 3, "9") & ".999") Then Txt = "خطأ : تجاوز العدد الحد الأقصى !" : GoTo kh_Exit ' Overflow
'======================================
nCurr = NCurr_Si & "-" & IIf(NCurr_Pl = "", NCurr_Si, IIf(NCurr_Si = "", "", NCurr_Pl))
'======================================
Dim intPart, dcPart, Txt3, frmtstr, Txtchar
intPart = Split(Num, ".")
dcPart = intPart(UBound(intPart))
Txt3 = intPart(LBound(intPart))
'Txt1 = Format(Txt3, String(Val(ii + 1) * 3, "0") )
frmtstr = String(Val(ii + 1) * 3, "0")
For i = 1 To Len(frmtstr)
Txtchar = Mid(Txt3, i, 1)
If Txtchar = "" Then Txt3 = "0" & Txt3
Next i
dcPart = "." & dcPart
Txt1 = Txt3 & dcPart
'======================================
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(Gender))
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 & Neg$ & Txt & kh_dText(Num, NCurr_Si, Trim(NCurrDec_Si), Decimal_Count, Trim(NCurrDec_Pl), dGender) & MyEndTx
'======================================
kh_Exit:
Tafqit = 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 Num 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$, Td2$
Dim dcPart
'On Error GoTo 1
If co = 0 Then GoTo 1
If NCur = "" Then Ndec = ""
If Val(Num) Then dwow = wow
dcPart = split(Num, ".")
Td1 = IIF(UBound(dcPart) = 0, 0, "." & dcPart(UBound(dcPart)) )
Td = Format( CCur(Td1), "0." & String(co, "0"))
If CDbl(Td) = 0 Or CDbl(Td) = 1 Then Td1 = "": GoTo 1
If Len(Ndec) Then
Ndec = " " & Ndec
Td2 = Td * CInt("1" & String(co, "0"))
If Len(Ndec_pl) And co < 4 Then Td2 = dwow & kh_nText(Format(Td2, "000"), Ndec & "-" & Ndec_pl, 1 + CInt(dsx), 1, 0): GoTo 1
Else
Ndec = " " & NCur: Td2 = Td
End If
Td2 = dwow & " " & Chr(40) & Td2 & Chr(41) & Ndec
1: kh_dText = Td2
End Function
ثم أنشيء ملف كَالْكْ جديد، ثم الذهاب إلى :
Tools → Macros → Edit macro...
أو بالعربية: أدوات → ماكرو → حرر ماكرو... (قد تكون Edit Macro بسبب عدم ترجمتها)
ونسخه في النافذة التالية قبل Sub Main ثم الضغط على زر الحفظ
مثال للاستخدام في الصورة أسفله :
يُرجى الانتباه إلى أن دالة التفقيط تعمل في برنامج ليبر أوفيس المُثبَّت على الجهاز، إذا أردت أن تعمل الدالة مع ملف تود إرساله إلى شخص لا يتوفر على هذه الدالة، يجب حينها نسخ النص البرمجي في وحدة ماكرو مدمجة مع الملف.