عرض مشاركة واحدة
  #1  
قديم 04-26-2021, 07:30 PM
الصورة الرمزية ابن الوليد
ابن الوليد 
::..مشرف برامج مايكروسوفت..::
 
تاريخ التسجيل: Mar 2021
الدولة: مصر
المشاركات: 160
معدل تقييم المستوى: 20
ابن الوليد is a splendid one to beholdابن الوليد is a splendid one to beholdابن الوليد is a splendid one to beholdابن الوليد is a splendid one to beholdابن الوليد is a splendid one to beholdابن الوليد is a splendid one to beholdابن الوليد is a splendid one to behold


Arrow دالة تفقيط تحويل الرقم الى نص بالعربي تفقيط الاكسيل

 

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




كود:
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‏ (30.0 كيلوبايت, المشاهدات 0)

التوقيع
ســبحان الله وبحــمده سبحان الله العــظيم
" يا حي يا قيوم ، برحمتك أستغيث ، أصلح لي شأني كله ، ولا تكلني إلى نفسي طرفة عين "
رد مع اقتباس