( موضوع مميز )دالة التفقيط

جوده · يوليو 11, 2009

اخى الكريم ابو تامر

مشكور جدا على المجهد الرائع فى ادراج الصورة على التعليقواسمح لى بالسؤال الاتى ومعلشهو خارج الموضوع

ارجو شرح دالة ARBNUM2TEXT وهى خاصة بتفقط المجموع مع العلم انها غير مدرجة بقائمة الدوال الموجودة باى ملف اكسيل

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

يوليو 11, 2009

الاخ goda509129

دالة ( ARBNUM2TEXT ) هى دالة خاصة يقوم بصناعتها احد الاخوة

ولا تظهر فى قائمة الدوال الا بعد اضافة الكود الخاص بها الى الملف

وعند اضافة الكود تظهر تحت بند ( معرفة بواسطة المستخدم ) فى اخر مجموعة الدوال

اما اذا اردت شرح طريقة استخدامها

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

**سالم شباني** · يوليو 11, 2009

السلام عليكم

بعد إذن أستاذنا أبو ثامر

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

أرجو أن يكون هو المطلوب

_____.rar

يوليو 11, 2009

لا بأس اخى سالم

الاخ goda509129

وجدت لك ملف دالة الدرجات التى اشرت اليها

وهى تخص استاذنا الفاضل / أبو هادى

وبه توضيح لنتائجها

_______.rar

**يوسف عطا** · يوليو 11, 2009

قد يكون هذا هو الكود الذى ذكره الأخ جودة

أعتذر عزيزى ابو تامر

لم أرى مشاركتك إلا بعد أن كتبت مشاركتى

تقبل إعتذارى

[

Option Explicit

Public Const vArabic As Byte = 1
Public Const vEnglish As Byte = 2
Public Const vMale As Byte = 0
Public Const vFemale As Byte = 1

Private Function myNz(ByVal InValue, Optional ByVal ValueIfNull = Null)
  myNz = IIf(IsNull(InValue), IIf(IsNull(ValueIfNull), Empty, ValueIfNull), InValue)
End Function

Private Function Delete(S As String, Index As Integer, Count As Integer) As String
  Delete = Left(S, Index - 1) + _
           Mid(S, Index + Count, Len(S))
End Function

Private Function Insert(Source, S As String, Index As Integer) As String
  Dim LPart As String
  Dim RPart As String

  LPart = Left(S, Index - 1)
  RPart = Mid(S, Index, Len(S))
  Insert = LPart & Source & RPart
End Function

Private Function AddAnd(s1 As String, S2 As String, S3 As String, _
                        And_ As String, Lang As Byte) As String
  Dim InAnd_   As String
  Dim CollectS As String

  If Lang = vArabic Then InAnd_ = " " + And_ Else InAnd_ = And_ + " "
  If (s1 <> "") And (S2 <> "") Then And_ = InAnd_ Else And_ = ""
  CollectS = s1 + And_ + S2
  If (CollectS <> "") And (S3 <> "") Then And_ = InAnd_ Else And_ = ""
  AddAnd = CollectS + And_ + S3
End Function

Private Function S2Double(Single_ As Variant, Sex As Byte) As String
  Dim LLeter As Integer
  Dim K      As Byte
  Dim Sngl_1 As String
  Dim Sngl_2 As String

  K = InStr(1, Single_ & " ", " ")
  Sngl_1 = Left(Single_, K - 1)
  Sngl_2 = ""
  If K < Len(Single_) Then
    Sngl_2 = Mid(Single_, K + 1, Len(Single_))
  End If

  If Sngl_2 <> "" Then
    If Right(Sngl_2, 1) = "ة" Then
      Sngl_2 = Left(Sngl_2, Len(Sngl_2) - 1) & "تان"
    Else
      Sngl_2 = Sngl_2 & "ان"
    End If
  End If

  If Sngl_1 <> "" Then LLeter = Asc(Right(Sngl_1, 1))

  Select Case LLeter
    Case 201 ' "ة"
      Sngl_1 = Left(Sngl_1, Len(Sngl_1) - 1) & "تان"
    Case 236 ' "ى"
      Sngl_1 = Left(Sngl_1, Len(Sngl_1) - 1) & "يان"
    Case 199 ' "ا"
      Sngl_1 = Left(Sngl_1, Len(Sngl_1) - 1) & "وان"
    Case 193 ' "ء"
      If Right(Sngl_1, 2) = "اء" Then
        If Sex = 1 Then
          Sngl_1 = Left(Sngl_1, Len(Sngl_1) - 1) & "وان"
        Else
          Sngl_1 = Sngl_1 & "ان"
        End If
      End If
    Case Else
      If Sngl_1 <> "" Then Sngl_1 = Sngl_1 & "ان"
  End Select

  If Sngl_2 <> "" Then
    S2Double = Sngl_1 & " " & Sngl_2
  Else
    S2Double = Sngl_1
  End If
End Function

Private Function Fmale(Num As Byte, Sex As Byte, Female()) As String
  Dim Two(1 To 4) As String
  Dim InSex As Byte

  Two(1) = "أحد"
  Two(2) = "اثنان"
  Two(3) = "إحدى"
  Two(4) = "ة"

  Select Case Sex
    Case vMale:
      Select Case Num
        Case 1:             Fmale = Mid(Female(1), 1, 4)
        Case 2:             Fmale = Two(2)
        Case 8:             Fmale = Female(Num) + "ي" + Two(4)
        Case 3 To 7, 9, 10: Fmale = Female(Num) + Two(4)
        Case 11:            Fmale = Two(1) + " " + Female(10)
        Case 12:            Fmale = Mid(Two(2), 1, 4) + " " + Female(10)
        Case 13 To 19:      Fmale = Female(Num - 10) + Two(4) + " " + Female(10)
      End Select
    Case vFemale:
      Select Case Num
        Case 1 To 10:       Fmale = Female(Num)
        Case 11:            Fmale = Two(3) + " " + Female(10) + Two(4)
        Case 12:            Fmale = Mid(Female(2), 1, 5) + " " + Female(10) + Two(4)
        Case 13 To 19:      Fmale = Female(Num - 10) + " " + Female(10) + Two(4)
      End Select
    End Select
End Function

Private Function Tens(Num As Byte, Female()) As String
  Const Noon = "ون"

  Select Case Num
    Case 2:      Tens = Female(10) + Noon
    Case 3 To 9: Tens = Female(Num) + Noon
  End Select
End Function

Private Function Hunds(Num As Byte, Female()) As String
  Const Hund = "مائة"

  Select Case Num
    Case 1:      Hunds = Hund
    Case 2:      Hunds = Mid(Hund, 1, 3) + Mid(Female(2), 4, 3)
    Case 3 To 9: Hunds = Female(Num) + Hund
   End Select
End Function

Private Function Tenteen(Num As Byte, ETens()) As String
  Const een = "een"

  Num = Num Mod 10
  Select Case Num
    Case 3 To 9:
      Tenteen = Mid(ETens(Num), 1, Len(ETens(Num)) - 1) + een
  End Select
End Function

Private Function EHunds(Num As Byte, ESingle()) As String
  EHunds = ESingle(Num) + " hundred"
End Function

Private Function ReFormat(InNum As Double, Dec As Byte) As Double
  Dim NewFormat As String

  If Dec > 0 Then NewFormat = "0." Else NewFormat = "0"
  NewFormat = NewFormat & String(Dec, "0")
  ReFormat = Format(InNum, NewFormat)
End Function

Private Function ReStr(InNum As String) As String
  Dim K As Byte
  Dim Digits As Byte
  Dim Num_ As String

  Num_ = LTrim(InNum)
  K = InStr(1, Num_, "E+", 1)
  If K > 0 Then
    Digits = Val(Mid(Num_, K + 2, 3))
    Num_ = Left(Num_, K - 1)
    Num_ = Delete(Num_, 2, 1)
    Do While Len(Num_) - 1 < Digits
      Num_ = Insert(Num_, "0", 1)
    Loop
  End If
  ReStr = Num_
End Function

Private Function AOnly(Num_ As String, FracS As String, Single_ As String, _
                       Plural As String, Parts As Byte, Sex As Byte, Dec As Byte) As String
  Const And_ As String * 1 = "و"
  Const Lang = vArabic
  Dim PartNum(0 To 5) As Long
  Dim Result1(0 To 5) As String
  Dim Parts_(0 To 11) As String
  Dim Female(1 To 10) As Variant
  Dim TempI           As Byte
  Dim Sex2            As Byte
  Dim K               As Byte
  Dim Only_           As String
  Dim OnlyPart        As String
  Dim Part_           As String
  Dim TempS           As String
  Dim Sngl_1          As String
  Dim Sngl_2          As String
  Dim N1  As Byte, N2    As Byte, N3    As Byte
  Dim N1_ As String, N2_ As String, N3_ As String

  If Val(Num_) = 0 Then
    If FracS = "" Then
      AOnly = RTrim("صفر " & Single_)
    Else
      AOnly = FracS & " " & Single_
    End If
    Exit Function
  End If

  Female(1) = "واحدة"
  Female(2) = "اثنتان"
  Female(3) = "ثلاث"
  Female(4) = "أربع"
  Female(5) = "خمس"
  Female(6) = "ست"
  Female(7) = "سبع"
  Female(8) = "ثمان"
  Female(9) = "تسع"
  Female(10) = "عشر"

  Parts_(0) = ""
  Parts_(1) = "ألف"
  Parts_(2) = "مليون"
  Parts_(3) = "مليار"
  Parts_(4) = "ترليون"
  Parts_(5) = "كدرليون"
  Parts_(6) = ""
  Parts_(7) = "آلاف"
  Parts_(8) = "ملايين"
  Parts_(9) = "مليارات"
  Parts_(10) = "ترليونات"
  Parts_(11) = "كدرليونات"

  K = InStr(1, Single_ & " ", " ")
  Sngl_1 = Left(Single_, K - 1)
  Sngl_2 = ""
  If K < Len(Single_) Then
    Sngl_2 = Mid(Single_, K + 1, Len(Single_))
  End If

  For K = 0 To Parts - 1
    PartNum(K) = Val(Mid(Num_, (K * 3) + 1, 3))
  Next K

    Sex2 = Sex
    For K = 0 To (Parts - 1)
      If K = (Parts - 1) Then Sex = Sex2 Else Sex = vMale
      TempS = Mid(Num_, (K * 3) + 1, 3)
      TempI = Val(Mid(TempS, 2, 2))
      N1 = Val(Mid(TempS, 1, 1))
      N2 = Val(Mid(TempS, 2, 1))
      N3 = Val(Mid(TempS, 3, 1))
      '{------------------------------------------}
      N1_ = "": N2_ = "": N3_ = ""
      If N1 > 0 Then N1_ = Hunds(CByte(N1), Female())
      If PartNum(K) = 200 Then N1_ = Mid(N1_, 1, Len(N1_) - 1)
      Select Case TempI
        Case 1 To 2:
          If K = Parts - 1 Then If FracS <> "" Then N3_ = Fmale(N3, CByte(Sex), Female())  'Sex
        Case 3 To 19:
          N3_ = Fmale(TempI, CByte(Sex), Female())
        Case 20 To 99:
          N2_ = Tens(CByte(N2), Female())
          If N3 > 0 Then N3_ = Fmale(N3, CByte(Sex), Female())
          If (N3 Mod 10 = 1) And (Sex = vFemale) Then N3_ = "إحدى"
      End Select
      OnlyPart = AddAnd(N1_, N3_, N2_, And_, Lang)
      '{------------------------------------------}
      If PartNum(K) > 100 Then
        Select Case TempI
          Case 1, 2:
            OnlyPart = AddAnd(OnlyPart, Parts_(Parts - K - 1), "", "", Lang)
        End Select
      End If
      '{------------------------------------------}
      Part_ = ""
      If PartNum(K) > 0 Then
        Part_ = Parts_(Parts - K - 1)
        If Part_ <> "" Then
          Select Case TempI
            Case 2:        Part_ = Part_ + "ان"
            Case 3 To 10:  Part_ = Parts_((Parts - K - 1) + 6)
            Case 11 To 99: Part_ = Part_ + "ا"
          End Select
        End If
      End If
      '{------------------------------------------}
      If Part_ <> "" Then
        If TempI >= 1 And TempI <= 2 Then
           OnlyPart = AddAnd(OnlyPart, Part_, "", And_, Lang)
        Else
          OnlyPart = AddAnd(OnlyPart, Part_, "", "", Lang)
        End If
      End If
      Result1(K) = (OnlyPart)
    Next K
    '{------------------------------------------}
    N1_ = AddAnd(Result1(0), Result1(1), Result1(2), And_, Lang)
    N2_ = AddAnd(Result1(3), Result1(4), Result1(5), And_, Lang)
    Only_ = AddAnd(N1_, N2_, "", And_, Lang)

    If FracS <> "" Then
      If Only_ <> "" Then FracS = " " + FracS
      Only_ = AddAnd(Only_, FracS, "", And_, Lang)
    End If
    If Only_ <> "" Then
      If Mid(Only_, Len(Only_), 1) = "ا" Then
        If Mid(Only_, Len(Only_) - 1, 2) <> "تا" Then
          Only_ = Mid(Only_, 1, Len(Only_) - 1)
        End If
      End If
      If TempS = "000" Then
        If Mid(Only_, Len(Only_) - 1, 2) = "ان" Then
          Only_ = Mid(Only_, 1, Len(Only_) - 1)
        End If
      End If
    End If
    '{------------------------------------------}
    If FracS = "" Then
      Select Case TempI
        Case 0: If Only_ <> "" Then Only_ = AddAnd(Only_, Single_, "", "", Lang)
        Case 1: Only_ = AddAnd(Only_, AddAnd(Single_, Fmale(1, CByte(Sex), Female()), "", "", Lang), "", And_, Lang)
        Case 2: Only_ = AddAnd(Only_, AddAnd(S2Double(Single_, CByte(Sex)), Fmale(2, CByte(Sex), Female()), "", "", Lang), "", And_, Lang)
        Case 3 To 10:
          If Sngl_2 <> "" Then
            If Right(Sngl_2, 1) = "ة" Then
              Only_ = AddAnd(Only_, Plural, Sngl_2, "", Lang)
            Else
              Only_ = AddAnd(Only_, Plural, Sngl_2 & "ة", "", Lang)
            End If
          Else
            Only_ = AddAnd(Only_, Plural, "", "", Lang)
          End If
        Case 11 To 99:
          If Sngl_1 <> "" Then
            Only_ = AddAnd(Only_, Sngl_1, "", "", Lang)
            N1_ = Mid(Only_, Len(Only_), 1)
            Select Case N1_
              Case "ة", "ى", "ا"
              Case Else
                Only_ = Only_ + "ا"
            End Select
            N1_ = Mid(Only_, Len(Only_) - 2, 3)
            'هذا الشرط لحل مشكلة عدم التمييز بين "ء" و "ل" 2002/08/24
            If N1_ = "اءا" And Asc(Right(Sngl_1, 1)) = 193 Then
              Only_ = Left(Only_, Len(Only_) - 1)
            End If
            If Sngl_2 <> "" Then
              If Right(Only_, 1) = "ا" Then
                Only_ = AddAnd(Only_, Sngl_2 & "ا", "", "", Lang)
              Else
                Only_ = AddAnd(Only_, Sngl_2, "", "", Lang)
              End If
            Else
              Only_ = AddAnd(Only_, Sngl_2, "", "", Lang)
            End If
          End If
      End Select
    Else
      Only_ = AddAnd(Only_, Sngl_1, Sngl_2, "", Lang)
    End If
    AOnly = (Only_)
End Function

Private Function EOnly(Num_ As String, FracS As String, Single_ As String, _
                       Plural As String, Parts As Byte, Dec As Byte) As String
  Const Lang = vEnglish
  Dim ESingle(1 To 12) As Variant
  Dim ETens(2 To 9)    As Variant
  Dim EParts_(0 To 5)  As String
  Dim PartNum(0 To 5)  As Long
  Dim Result1(0 To 5)  As String
  Dim TempS            As String
  Dim TempI            As Byte
  Dim Sex2             As Byte
  Dim OnlyPart         As String
  Dim Part_            As String
  Dim Only_            As String
  Dim Leng             As Integer
  Dim K                As Integer
  Dim N1  As Byte, N2    As Byte, N3    As Byte
  Dim N1_ As String, N2_ As String, N3_ As String

  If Val(Num_) = 0 Then
    If FracS = "" Then
     'EOnly = LTrim(Single_ & " zero")
      EOnly = RTrim("zero " & Single_)
    Else
      EOnly = Single_ & " " & FracS
    End If
    Exit Function
  End If

  ESingle(1) = "one"
  ESingle(2) = "two"
  ESingle(3) = "three"
  ESingle(4) = "four"
  ESingle(5) = "five"
  ESingle(6) = "six"
  ESingle(7) = "seven"
  ESingle(8) = "eight"
  ESingle(9) = "nine"
  ESingle(10) = "ten"
  ESingle(11) = "eleven"
  ESingle(12) = "twelve"

  ETens(2) = "twenty"
  ETens(3) = "thirty"
  ETens(4) = "forty"
  ETens(5) = "fifty"
  ETens(6) = "sixty"
  ETens(7) = "seventy"
  ETens(8) = "eighty"
  ETens(9) = "ninety"

  EParts_(0) = ""
  EParts_(1) = "thousund"
  EParts_(2) = "million"
  EParts_(3) = "billion"
  EParts_(4) = "trillion"
  EParts_(5) = "quadrillion"

  For K = 0 To Parts - 1
    PartNum(K) = Val(Mid(Num_, (K * 3) + 1, 3))
  Next K

  For K = 0 To (Parts - 1)
    TempS = Mid(Num_, (K * 3) + 1, 3)
    TempI = Val(Mid(TempS, 2, 2))
    N1 = Val(Mid(TempS, 1, 1))
    N2 = Val(Mid(TempS, 2, 1))
    N3 = Val(Mid(TempS, 3, 1))
    '{------------------------------------------}
    N1_ = "": N2_ = "": N3_ = ""
    If N1 > 0 Then N1_ = EHunds(CByte(N1), ESingle())
    Select Case TempI
      Case 1 To 12:  N3_ = ESingle(TempI)
      Case 13 To 19: If N3 > 0 Then N3_ = Tenteen(CByte(TempI), ETens())
      Case 20 To 99:
        N2_ = ETens(N2)
        If N3 > 0 Then
          N3_ = N2_ + "-" + ESingle(N3)
          N2_ = ""
        End If
    End Select
    OnlyPart = AddAnd(N1_, N2_, N3_, "", Lang)
    '{------------------------------------------}
    Part_ = ""
    If PartNum(K) > 0 Then
      Part_ = EParts_(Parts - K - 1)
      If Part_ <> "" Then Part_ = EParts_((Parts - K - 1))
    End If
    Result1(K) = AddAnd(OnlyPart, Part_, "", "", Lang)
  Next K
  '{------------------------------------------}
  N1_ = AddAnd(Result1(0), Result1(1), Result1(2), "", Lang)
  N2_ = AddAnd(Result1(3), Result1(4), Result1(5), "", Lang)
  Only_ = AddAnd(N1_, N2_, "", "", Lang)

  Leng = Len(Only_)
  Only_ = AddAnd(Only_, FracS, "", " and", Lang)
  If Only_ <> "" Then
   'Only_ = AddAnd(Single_, Only_, "", "", Lang)
    If Val(Num_) = 1 Then
      Only_ = AddAnd(Only_, Single_, "", "", Lang)
    Else
      Only_ = AddAnd(Only_, Plural, "", "", Lang)
    End If
    EOnly = Only_
  End If
End Function

Private Function S_Only(InNum As Variant, Lang As Byte, FracType As Byte) As Variant
  Dim Num_  As String
  Dim K     As Byte
  Dim Dec   As Byte
  Dim FType As Byte

  If IsNull(InNum) Then
    S_Only = Null
    Exit Function
  End If

  Num_ = Str(InNum)
  K = InStr(1, Num_, ".", 1)
  If K > 0 Then
    Dec = Len(Num_) - K
    If Dec < 2 Then Dec = 2
  Else
   Dec = 0
  End If

  FType = FracType
  If FType <> 2 Then FType = 1

  S_Only = B_Only(InNum, Lang, 0, Dec, "", "", 0, "", "", FType)
End Function

Private Function B_Only(InNum As Variant, Lang As Byte, Sex As Byte, Dec As Byte, _
                        Single_ As String, Plural As String, _
                        FSex As Byte, SFrac As String, PFrac As String, _
                        FracType As Byte) As Variant
  Dim Leng    As Byte
  Dim Parts   As Byte
  Dim K       As Byte
  Dim FracVal As Double
  Dim Num_    As String
  Dim FracS   As String
  Dim FracNum As String
  Dim Only    As String
  Dim And_    As String

  If IsNull(InNum) Then
    B_Only = Null
    Exit Function
  End If

  Num_ = Str(InNum)
  If InStr(1, Num_, "E+", 1) > 0 Then
    Num_ = ReStr(Num_)
    FracVal = 0
    GoTo DoProcess
  End If

  Num_ = ReFormat(Val(InNum), Dec)
  K = InStr(1, Num_, ".", 1)
  If K > 0 Then FracS = "0" & Mid(Num_, K, Dec + 1) Else FracS = ""
  FracVal = Val(FracS)
  Num_ = Trim(Str(Fix(InNum)))

  Do While Len(FracS) < Dec + 2
    FracS = Insert(FracS, "0", 1)
  Loop

DoProcess:
  If FracVal = 0 Then FracS = ""
  FracNum = Trim(Mid(FracS, 3, Len(FracS)))
  If FracS <> "" Then
    Select Case FracType
      Case 2
        Select Case Lang
          Case vArabic:  FracS = "1" & String(Dec, "0") & "/" & CDbl(Format(FracNum, String(Dec, "0")))
          Case vEnglish: FracS = CDbl(Format(FracNum, String(Dec, "0"))) & "/" & "1" & String(Dec, "0")
        End Select
      Case 3
        FracS = CLng(FracNum) & " " & SFrac
        'If Lang = vEnglish And CDbl(FracNum) > 1 Then FracS = FracS & "(s)"
      Case 4
        Leng = Len(FracNum)
        Parts = Fix((Leng + 2) / 3)
        For K = 1 To (Parts * 3) - Leng
          FracNum = Insert("0", FracNum, 1)
        Next K
        Select Case Lang
          Case vArabic:  FracS = AOnly(FracNum, "", SFrac, PFrac, Parts, FSex, FracType)
          Case vEnglish: 'FracS = EOnly(FracNum, "", "", "", Parts, 0) & " " & SFrac
                          FracS = EOnly(FracNum, "", SFrac, PFrac, Parts, 0) '& " " & SFrac
                         'If CDbl(FracNum) > 1 Then FracS = FracS & "(s)"
        End Select
    End Select
  End If

  Leng = Len(Num_)
  Parts = Fix((Leng + 2) / 3)

  For K = 1 To (Parts * 3) - Leng
    Num_ = Insert("0", Num_, 1)
  Next K

  If Len(Num_) > 18 Then
    B_Only = InNum
    Exit Function
  End If

  Select Case FracType
    Case 1, 2
      Select Case Lang
        Case vArabic:  Only = AOnly(Num_, FracS, Single_, Plural, Parts, Sex, Dec)
        Case vEnglish: Only = EOnly(Num_, FracS, Single_, Plural, Parts, Dec)
      End Select
    Case 3, 4
      Select Case Lang
        Case vArabic:  Only = AOnly(Num_, "", Single_, Plural, Parts, Sex, Dec)
                       If CDbl(Num_) = 0 And FracS <> "" Then Only = ""
                       If FracType = 3 Then And_ = "و " Else And_ = "و"
                       If FracS <> "" Then Only = AddAnd(Only, FracS, "", And_, CByte(Lang))
        Case vEnglish: Only = EOnly(Num_, "", Single_, Plural, Parts, Dec)
                       If CDbl(Num_) = 0 And FracS <> "" Then Only = ""
                       If FracS <> "" Then Only = AddAnd(Only, FracS, "", " and", CByte(Lang))
      End Select
  End Select

  If Only <> "" Then
    Select Case Lang
     'Case vArabic:  B_Only = "فقط " & Only
      Case vArabic:  B_Only = Only & " فقط"
     'Case vEnglish: B_Only = Only & " only"
      Case vEnglish: B_Only = "Only " & Only
    End Select
  End If
End Function

Function ArbNum2Text(ByVal InNum, _
            Optional ByVal DecimalPlaces = Null, _
            Optional ByVal FractionType = 1, _
            Optional ByVal CurrencySingle = "", _
            Optional ByVal CurrencyPlural = "", _
            Optional ByVal CurrencySex = 0, _
            Optional ByVal FractionSingle = "", _
            Optional ByVal FractionPlural = "", _
            Optional ByVal FractionSex = 0) As Variant

  Dim Negative As String

  If IsNull(InNum) Then
    ArbNum2Text = Null
    Exit Function
  Else
    If InNum < 0 Then
      InNum = Abs(InNum)
      Negative = "سالب "
    End If
  End If

  If IsNull(FractionType) Then FractionType = 1

  If myNz(CurrencySingle) = Empty Or myNz(CurrencyPlural) = Empty Then
    If Not IsNull(DecimalPlaces) Then
      InNum = ReFormat(CDbl(InNum), CByte(DecimalPlaces))
    End If
    ArbNum2Text = Negative & S_Only(InNum, vArabic, CByte(FractionType))
    Exit Function
  End If

  If IsNull(DecimalPlaces) Then DecimalPlaces = 3
  If InNum <> Fix(InNum) Then
    If myNz(FractionSingle) = Empty Or myNz(FractionPlural) = Empty Then
      If FractionType > 2 Then FractionType = 1
    End If
  End If

  ArbNum2Text = Negative & _
                B_Only(CDbl(myNz(InNum)), vArabic, CByte(myNz(CurrencySex)), _
                       CByte(myNz(DecimalPlaces)), CStr(myNz(CurrencySingle)), _
                       CStr(myNz(CurrencyPlural)), CByte(myNz(FractionSex)), _
                       CStr(myNz(FractionSingle)), CStr(myNz(FractionPlural)), _
                       CByte(myNz(FractionType)))

  '-- تعديل خاص لأحد أعضاء منتدى أوفيسنا ---------------------------------
  If CStr(myNz(CurrencySingle)) = "درجة" And _
     CStr(myNz(FractionSingle)) = "جزء" Then

    Dim Grade As String
    Dim FracS As String
    Dim Pos As Integer

    Grade = Negative & _
            B_Only(CDbl(myNz(InNum)), vArabic, CByte(myNz(CurrencySex)), _
                   CByte(myNz(DecimalPlaces)), CStr(myNz(CurrencySingle)), _
                   CStr(myNz(CurrencyPlural)), CByte(myNz(FractionSex)), _
                   CStr(myNz(FractionSingle)), CStr(myNz(FractionPlural)), _
                   CByte(myNz(FractionType)))

    Select Case CDbl(myNz(InNum)) - Fix(CDbl(myNz(InNum)))
      Case 0:
      Case 0.25: FracS = IIf(Fix(CDbl(myNz(InNum))) = 0, "ربع درجة فقط", "ربع فقط")
      Case 0.5:  FracS = IIf(Fix(CDbl(myNz(InNum))) = 0, "نصف درجة فقط", "نصف فقط")
      Case 0.75: FracS = IIf(Fix(CDbl(myNz(InNum))) = 0, "ثلاثة أرباع درجة فقط", "ثلاثة أرباع فقط")
      Case Else: FracS = " " & CDbl(myNz(InNum)) - Fix(CDbl(myNz(InNum))) & " فقط"
    End Select

    If FracS <> "" Then
      Pos = InStr(1, Grade, " و ")
      If Pos > 0 Then
        Grade = Left(Grade, Pos + 1) & FracS
      Else
        Grade = FracS
      End If
    End If

    Pos = InStr(1, Grade, "درجة واحدة")
    If Pos > 0 Then Grade = Left(Grade, Pos + 4) & Mid(Grade, Pos + 11)
    Pos = InStr(1, Grade, "درجتان اثنتان")
    If Pos > 0 Then Grade = Left(Grade, Pos + 6) & Mid(Grade, Pos + 14)
    If CDbl(myNz(InNum)) = 0 Then Grade = "صفر"
    ArbNum2Text = Grade
  End If
  '-- نهاية التعديل -------------------------------------------------------

End Function

Function EngNum2Text(ByVal InNum, _
            Optional ByVal DecimalPlaces = Null, _
            Optional ByVal FractionType = 1, _
            Optional ByVal CurrencySingle = "", _
            Optional ByVal CurrencyPlural = "", _
            Optional ByVal FractionSingle = "", _
            Optional ByVal FractionPlural = "") As Variant

  Dim Negative As String

  If IsNull(InNum) Then
    EngNum2Text = Null
    Exit Function
  Else
    If InNum < 0 Then
      InNum = Abs(InNum)
      Negative = "Negative only "
    Else
      Negative = "Only "
    End If
  End If

  If IsNull(FractionType) Then FractionType = 1
  If myNz(CurrencyPlural) = Empty Then CurrencyPlural = CurrencySingle '& "(s)"
  If myNz(FractionPlural) = Empty Then FractionPlural = FractionSingle '& "(s)"

  If myNz(CurrencySingle) = Empty Then
    If Not IsNull(DecimalPlaces) Then
      InNum = ReFormat(CDbl(InNum), CByte(DecimalPlaces))
    End If
    EngNum2Text = Negative & S_Only(InNum, vEnglish, CByte(FractionType))
    Exit Function
  End If

  If IsNull(DecimalPlaces) Then DecimalPlaces = 3
  If InNum <> Fix(InNum) Then
    If myNz(FractionSingle) = Empty Then
      If FractionType > 2 Then FractionType = 1
    End If
  End If

  EngNum2Text = Negative & Mid( _
                B_Only(CDbl(myNz(InNum)), vEnglish, 0, _
                       CByte(myNz(DecimalPlaces)), CStr(myNz(CurrencySingle)), _
                       CStr(myNz(CurrencyPlural)), 0, _
                       CStr(myNz(FractionSingle)), CStr(myNz(FractionPlural)), _
                       CByte(myNz(FractionType))), 6)
End Function

تم تعديل يوليو 11, 2009 بواسطه يوسف عطا

**يوسف عطا** · نوفمبر 6, 2011

قد يكون هذا هو الكود الذى ذكره الأخ جودة

أعتذر عزيزى ابو تامر

لم أرى مشاركتك إلا بعد أن كتبت مشاركتى

تقبل إعتذارى

[

نص برمجي

Option Explicit

Public Const vArabic As Byte = 1

Public Const vEnglish As Byte = 2

Public Const vMale As Byte = 0

Public Const vFemale As Byte = 1

Private Function myNz(ByVal InValue, Optional ByVal ValueIfNull = Null)

myNz = IIf(IsNull(InValue), IIf(IsNull(ValueIfNull), Empty, ValueIfNull), InValue)

End Function

Private Function Delete(S As String, Index As Integer, Count As Integer) As String

Delete = Left(S, Index - 1) + _

Mid(S, Index + Count, Len(S))

End Function

Private Function Insert(Source, S As String, Index As Integer) As String

Dim LPart As String

Dim RPart As String

LPart = Left(S, Index - 1)

RPart = Mid(S, Index, Len(S))

Insert = LPart & Source & RPart

End Function

Private Function AddAnd(s1 As String, S2 As String, S3 As String, _

And_ As String, Lang As Byte) As String

Dim InAnd_ As String

Dim CollectS As String

If Lang = vArabic Then InAnd_ = " " + And_ Else InAnd_ = And_ + " "

If (s1 <> "") And (S2 <> "") Then And_ = InAnd_ Else And_ = ""

CollectS = s1 + And_ + S2

If (CollectS <> "") And (S3 <> "") Then And_ = InAnd_ Else And_ = ""

AddAnd = CollectS + And_ + S3

End Function

Private Function S2Double(Single_ As Variant, Sex As Byte) As String

Dim LLeter As Integer

Dim K As Byte

Dim Sngl_1 As String

Dim Sngl_2 As String

K = InStr(1, Single_ & " ", " ")

Sngl_1 = Left(Single_, K - 1)

Sngl_2 = ""

If K < Len(Single_) Then

Sngl_2 = Mid(Single_, K + 1, Len(Single_))

End If

If Sngl_2 <> "" Then

If Right(Sngl_2, 1) = "ة" Then

Sngl_2 = Left(Sngl_2, Len(Sngl_2) - 1) & "تان"

Else

Sngl_2 = Sngl_2 & "ان"

End If

End If

If Sngl_1 <> "" Then LLeter = Asc(Right(Sngl_1, 1))

Select Case LLeter

Case 201 ' "ة"

Sngl_1 = Left(Sngl_1, Len(Sngl_1) - 1) & "تان"

Case 236 ' "ى"

Sngl_1 = Left(Sngl_1, Len(Sngl_1) - 1) & "يان"

Case 199 ' "ا"

Sngl_1 = Left(Sngl_1, Len(Sngl_1) - 1) & "وان"

Case 193 ' "ء"

If Right(Sngl_1, 2) = "اء" Then

If Sex = 1 Then

Sngl_1 = Left(Sngl_1, Len(Sngl_1) - 1) & "وان"

Else

Sngl_1 = Sngl_1 & "ان"

End If

End If

Case Else

If Sngl_1 <> "" Then Sngl_1 = Sngl_1 & "ان"

End Select

If Sngl_2 <> "" Then

S2Double = Sngl_1 & " " & Sngl_2

Else

S2Double = Sngl_1

End If

End Function

Private Function Fmale(Num As Byte, Sex As Byte, Female()) As String

Dim Two(1 To 4) As String

Dim InSex As Byte

Two(1) = "أحد"

Two(2) = "اثنان"

Two(3) = "إحدى"

Two(4) = "ة"

Select Case Sex

Case vMale:

Select Case Num

Case 1: Fmale = Mid(Female(1), 1, 4)

Case 2: Fmale = Two(2)

Case 8: Fmale = Female(Num) + "ي" + Two(4)

Case 3 To 7, 9, 10: Fmale = Female(Num) + Two(4)

Case 11: Fmale = Two(1) + " " + Female(10)

Case 12: Fmale = Mid(Two(2), 1, 4) + " " + Female(10)

Case 13 To 19: Fmale = Female(Num - 10) + Two(4) + " " + Female(10)

End Select

Case vFemale:

Select Case Num

Case 1 To 10: Fmale = Female(Num)

Case 11: Fmale = Two(3) + " " + Female(10) + Two(4)

Case 12: Fmale = Mid(Female(2), 1, 5) + " " + Female(10) + Two(4)

Case 13 To 19: Fmale = Female(Num - 10) + " " + Female(10) + Two(4)

End Select

End Select

End Function

Private Function Tens(Num As Byte, Female()) As String

Const Noon = "ون"

Select Case Num

Case 2: Tens = Female(10) + Noon

Case 3 To 9: Tens = Female(Num) + Noon

End Select

End Function

Private Function Hunds(Num As Byte, Female()) As String

Const Hund = "مائة"

Select Case Num

Case 1: Hunds = Hund

Case 2: Hunds = Mid(Hund, 1, 3) + Mid(Female(2), 4, 3)

Case 3 To 9: Hunds = Female(Num) + Hund

End Select

End Function

Private Function Tenteen(Num As Byte, ETens()) As String

Const een = "een"

Num = Num Mod 10

Select Case Num

Case 3 To 9:

Tenteen = Mid(ETens(Num), 1, Len(ETens(Num)) - 1) + een

End Select

End Function

Private Function EHunds(Num As Byte, ESingle()) As String

EHunds = ESingle(Num) + " hundred"

End Function

Private Function ReFormat(InNum As Double, Dec As Byte) As Double

Dim NewFormat As String

If Dec > 0 Then NewFormat = "0." Else NewFormat = "0"

NewFormat = NewFormat & String(Dec, "0")

ReFormat = Format(InNum, NewFormat)

End Function

Private Function ReStr(InNum As String) As String

Dim K As Byte

Dim Digits As Byte

Dim Num_ As String

Num_ = LTrim(InNum)

K = InStr(1, Num_, "E+", 1)

If K > 0 Then

Digits = Val(Mid(Num_, K + 2, 3))

Num_ = Left(Num_, K - 1)

Num_ = Delete(Num_, 2, 1)

Do While Len(Num_) - 1 < Digits

Num_ = Insert(Num_, "0", 1)

Loop

End If

ReStr = Num_

End Function

Private Function AOnly(Num_ As String, FracS As String, Single_ As String, _

Plural As String, Parts As Byte, Sex As Byte, Dec As Byte) As String

Const And_ As String * 1 = "و"

Const Lang = vArabic

Dim PartNum(0 To 5) As Long

Dim Result1(0 To 5) As String

Dim Parts_(0 To 11) As String

Dim Female(1 To 10) As Variant

Dim TempI As Byte

Dim Sex2 As Byte

Dim K As Byte

Dim Only_ As String

Dim OnlyPart As String

Dim Part_ As String

Dim TempS As String

Dim Sngl_1 As String

Dim Sngl_2 As String

Dim N1 As Byte, N2 As Byte, N3 As Byte

Dim N1_ As String, N2_ As String, N3_ As String

If Val(Num_) = 0 Then

If FracS = "" Then

AOnly = RTrim("صفر " & Single_)

Else

AOnly = FracS & " " & Single_

End If

Exit Function

End If

Female(1) = "واحدة"

Female(2) = "اثنتان"

Female(3) = "ثلاث"

Female(4) = "أربع"

Female(5) = "خمس"

Female(6) = "ست"

Female(7) = "سبع"

Female(8) = "ثمان"

Female(9) = "تسع"

Female(10) = "عشر"

Parts_(0) = ""

Parts_(1) = "ألف"

Parts_(2) = "مليون"

Parts_(3) = "مليار"

Parts_(4) = "ترليون"

Parts_(5) = "كدرليون"

Parts_(6) = ""

Parts_(7) = "آلاف"

Parts_(8) = "ملايين"

Parts_(9) = "مليارات"

Parts_(10) = "ترليونات"

Parts_(11) = "كدرليونات"

K = InStr(1, Single_ & " ", " ")

Sngl_1 = Left(Single_, K - 1)

Sngl_2 = ""

If K < Len(Single_) Then

Sngl_2 = Mid(Single_, K + 1, Len(Single_))

End If

For K = 0 To Parts - 1

PartNum(K) = Val(Mid(Num_, (K * 3) + 1, 3))

Next K

Sex2 = Sex

For K = 0 To (Parts - 1)

If K = (Parts - 1) Then Sex = Sex2 Else Sex = vMale

TempS = Mid(Num_, (K * 3) + 1, 3)

TempI = Val(Mid(TempS, 2, 2))

N1 = Val(Mid(TempS, 1, 1))

N2 = Val(Mid(TempS, 2, 1))

N3 = Val(Mid(TempS, 3, 1))

'{------------------------------------------}

N1_ = "": N2_ = "": N3_ = ""

If N1 > 0 Then N1_ = Hunds(CByte(N1), Female())

If PartNum(K) = 200 Then N1_ = Mid(N1_, 1, Len(N1_) - 1)

Select Case TempI

Case 1 To 2:

If K = Parts - 1 Then If FracS <> "" Then N3_ = Fmale(N3, CByte(Sex), Female()) 'Sex

Case 3 To 19:

N3_ = Fmale(TempI, CByte(Sex), Female())

Case 20 To 99:

N2_ = Tens(CByte(N2), Female())

If N3 > 0 Then N3_ = Fmale(N3, CByte(Sex), Female())

If (N3 Mod 10 = 1) And (Sex = vFemale) Then N3_ = "إحدى"

End Select

OnlyPart = AddAnd(N1_, N3_, N2_, And_, Lang)

'{------------------------------------------}

If PartNum(K) > 100 Then

Select Case TempI

Case 1, 2:

OnlyPart = AddAnd(OnlyPart, Parts_(Parts - K - 1), "", "", Lang)

End Select

End If

'{------------------------------------------}

Part_ = ""

If PartNum(K) > 0 Then

Part_ = Parts_(Parts - K - 1)

If Part_ <> "" Then

Select Case TempI

Case 2: Part_ = Part_ + "ان"

Case 3 To 10: Part_ = Parts_((Parts - K - 1) + 6)

Case 11 To 99: Part_ = Part_ + "ا"

End Select

End If

End If

'{------------------------------------------}

If Part_ <> "" Then

If TempI >= 1 And TempI <= 2 Then

OnlyPart = AddAnd(OnlyPart, Part_, "", And_, Lang)

Else

OnlyPart = AddAnd(OnlyPart, Part_, "", "", Lang)

End If

End If

Result1(K) = (OnlyPart)

Next K

'{------------------------------------------}

N1_ = AddAnd(Result1(0), Result1(1), Result1(2), And_, Lang)

N2_ = AddAnd(Result1(3), Result1(4), Result1(5), And_, Lang)

Only_ = AddAnd(N1_, N2_, "", And_, Lang)

If FracS <> "" Then

If Only_ <> "" Then FracS = " " + FracS

Only_ = AddAnd(Only_, FracS, "", And_, Lang)

End If

If Only_ <> "" Then

If Mid(Only_, Len(Only_), 1) = "ا" Then

If Mid(Only_, Len(Only_) - 1, 2) <> "تا" Then

Only_ = Mid(Only_, 1, Len(Only_) - 1)

End If

End If

If TempS = "000" Then

If Mid(Only_, Len(Only_) - 1, 2) = "ان" Then

Only_ = Mid(Only_, 1, Len(Only_) - 1)

End If

End If

End If

'{------------------------------------------}

If FracS = "" Then

Select Case TempI

Case 0: If Only_ <> "" Then Only_ = AddAnd(Only_, Single_, "", "", Lang)

Case 1: Only_ = AddAnd(Only_, AddAnd(Single_, Fmale(1, CByte(Sex), Female()), "", "", Lang), "", And_, Lang)

Case 2: Only_ = AddAnd(Only_, AddAnd(S2Double(Single_, CByte(Sex)), Fmale(2, CByte(Sex), Female()), "", "", Lang), "", And_, Lang)

Case 3 To 10:

If Sngl_2 <> "" Then

If Right(Sngl_2, 1) = "ة" Then

Only_ = AddAnd(Only_, Plural, Sngl_2, "", Lang)

Else

Only_ = AddAnd(Only_, Plural, Sngl_2 & "ة", "", Lang)

End If

Else

Only_ = AddAnd(Only_, Plural, "", "", Lang)

End If

Case 11 To 99:

If Sngl_1 <> "" Then

Only_ = AddAnd(Only_, Sngl_1, "", "", Lang)

N1_ = Mid(Only_, Len(Only_), 1)

Select Case N1_

Case "ة", "ى", "ا"

Case Else

Only_ = Only_ + "ا"

End Select

N1_ = Mid(Only_, Len(Only_) - 2, 3)

'هذا الشرط لحل مشكلة عدم التمييز بين "ء" و "ل" 2002/08/24

If N1_ = "اءا" And Asc(Right(Sngl_1, 1)) = 193 Then

Only_ = Left(Only_, Len(Only_) - 1)

End If

If Sngl_2 <> "" Then

If Right(Only_, 1) = "ا" Then

Only_ = AddAnd(Only_, Sngl_2 & "ا", "", "", Lang)

Else

Only_ = AddAnd(Only_, Sngl_2, "", "", Lang)

End If

Else

Only_ = AddAnd(Only_, Sngl_2, "", "", Lang)

End If

End If

End Select

Else

Only_ = AddAnd(Only_, Sngl_1, Sngl_2, "", Lang)

End If

AOnly = (Only_)

End Function

Private Function EOnly(Num_ As String, FracS As String, Single_ As String, _

Plural As String, Parts As Byte, Dec As Byte) As String

Const Lang = vEnglish

Dim ESingle(1 To 12) As Variant

Dim ETens(2 To 9) As Variant

Dim EParts_(0 To 5) As String

Dim PartNum(0 To 5) As Long

Dim Result1(0 To 5) As String

Dim TempS As String

Dim TempI As Byte

Dim Sex2 As Byte

Dim OnlyPart As String

Dim Part_ As String

Dim Only_ As String

Dim Leng As Integer

Dim K As Integer

Dim N1 As Byte, N2 As Byte, N3 As Byte

Dim N1_ As String, N2_ As String, N3_ As String

If Val(Num_) = 0 Then

If FracS = "" Then

'EOnly = LTrim(Single_ & " zero")

EOnly = RTrim("zero " & Single_)

Else

EOnly = Single_ & " " & FracS

End If

Exit Function

End If

ESingle(1) = "one"

ESingle(2) = "two"

ESingle(3) = "three"

ESingle(4) = "four"

ESingle(5) = "five"

ESingle(6) = "six"

ESingle(7) = "seven"

ESingle(8) = "eight"

ESingle(9) = "nine"

ESingle(10) = "ten"

ESingle(11) = "eleven"

ESingle(12) = "twelve"

ETens(2) = "twenty"

ETens(3) = "thirty"

ETens(4) = "forty"

ETens(5) = "fifty"

ETens(6) = "sixty"

ETens(7) = "seventy"

ETens(8) = "eighty"

ETens(9) = "ninety"

EParts_(0) = ""

EParts_(1) = "thousund"

EParts_(2) = "million"

EParts_(3) = "billion"

EParts_(4) = "trillion"

EParts_(5) = "quadrillion"

For K = 0 To Parts - 1

PartNum(K) = Val(Mid(Num_, (K * 3) + 1, 3))

Next K

For K = 0 To (Parts - 1)

TempS = Mid(Num_, (K * 3) + 1, 3)

TempI = Val(Mid(TempS, 2, 2))

N1 = Val(Mid(TempS, 1, 1))

N2 = Val(Mid(TempS, 2, 1))

N3 = Val(Mid(TempS, 3, 1))

'{------------------------------------------}

N1_ = "": N2_ = "": N3_ = ""

If N1 > 0 Then N1_ = EHunds(CByte(N1), ESingle())

Select Case TempI

Case 1 To 12: N3_ = ESingle(TempI)

Case 13 To 19: If N3 > 0 Then N3_ = Tenteen(CByte(TempI), ETens())

Case 20 To 99:

N2_ = ETens(N2)

If N3 > 0 Then

N3_ = N2_ + "-" + ESingle(N3)

N2_ = ""

End If

End Select

OnlyPart = AddAnd(N1_, N2_, N3_, "", Lang)

'{------------------------------------------}

Part_ = ""

If PartNum(K) > 0 Then

Part_ = EParts_(Parts - K - 1)

If Part_ <> "" Then Part_ = EParts_((Parts - K - 1))

End If

Result1(K) = AddAnd(OnlyPart, Part_, "", "", Lang)

Next K

'{------------------------------------------}

N1_ = AddAnd(Result1(0), Result1(1), Result1(2), "", Lang)

N2_ = AddAnd(Result1(3), Result1(4), Result1(5), "", Lang)

Only_ = AddAnd(N1_, N2_, "", "", Lang)

Leng = Len(Only_)

Only_ = AddAnd(Only_, FracS, "", " and", Lang)

If Only_ <> "" Then

'Only_ = AddAnd(Single_, Only_, "", "", Lang)

If Val(Num_) = 1 Then

Only_ = AddAnd(Only_, Single_, "", "", Lang)

Else

Only_ = AddAnd(Only_, Plural, "", "", Lang)

End If

EOnly = Only_

End If

End Function

Private Function S_Only(InNum As Variant, Lang As Byte, FracType As Byte) As Variant

Dim Num_ As String

Dim K As Byte

Dim Dec As Byte

Dim FType As Byte

If IsNull(InNum) Then

S_Only = Null

Exit Function

End If

Num_ = Str(InNum)

K = InStr(1, Num_, ".", 1)

If K > 0 Then

Dec = Len(Num_) - K

If Dec < 2 Then Dec = 2

Else

Dec = 0

End If

FType = FracType

If FType <> 2 Then FType = 1

S_Only = B_Only(InNum, Lang, 0, Dec, "", "", 0, "", "", FType)

End Function

Private Function B_Only(InNum As Variant, Lang As Byte, Sex As Byte, Dec As Byte, _

Single_ As String, Plural As String, _

FSex As Byte, SFrac As String, PFrac As String, _

FracType As Byte) As Variant

Dim Leng As Byte

Dim Parts As Byte

Dim K As Byte

Dim FracVal As Double

Dim Num_ As String

Dim FracS As String

Dim FracNum As String

Dim Only As String

Dim And_ As String

If IsNull(InNum) Then

B_Only = Null

Exit Function

End If

Num_ = Str(InNum)

If InStr(1, Num_, "E+", 1) > 0 Then

Num_ = ReStr(Num_)

FracVal = 0

GoTo DoProcess

End If

Num_ = ReFormat(Val(InNum), Dec)

K = InStr(1, Num_, ".", 1)

If K > 0 Then FracS = "0" & Mid(Num_, K, Dec + 1) Else FracS = ""

FracVal = Val(FracS)

Num_ = Trim(Str(Fix(InNum)))

Do While Len(FracS) < Dec + 2

FracS = Insert(FracS, "0", 1)

Loop

DoProcess:

If FracVal = 0 Then FracS = ""

FracNum = Trim(Mid(FracS, 3, Len(FracS)))

If FracS <> "" Then

Select Case FracType

Case 2

Select Case Lang

Case vArabic: FracS = "1" & String(Dec, "0") & "/" & CDbl(Format(FracNum, String(Dec, "0")))

Case vEnglish: FracS = CDbl(Format(FracNum, String(Dec, "0"))) & "/" & "1" & String(Dec, "0")

End Select

Case 3

FracS = CLng(FracNum) & " " & SFrac

'If Lang = vEnglish And CDbl(FracNum) > 1 Then FracS = FracS & "(s)"

Case 4

Leng = Len(FracNum)

Parts = Fix((Leng + 2) / 3)

For K = 1 To (Parts * 3) - Leng

FracNum = Insert("0", FracNum, 1)

Next K

Select Case Lang

Case vArabic: FracS = AOnly(FracNum, "", SFrac, PFrac, Parts, FSex, FracType)

Case vEnglish: 'FracS = EOnly(FracNum, "", "", "", Parts, 0) & " " & SFrac

FracS = EOnly(FracNum, "", SFrac, PFrac, Parts, 0) '& " " & SFrac

'If CDbl(FracNum) > 1 Then FracS = FracS & "(s)"

End Select

End Select

End If

Leng = Len(Num_)

Parts = Fix((Leng + 2) / 3)

For K = 1 To (Parts * 3) - Leng

Num_ = Insert("0", Num_, 1)

Next K

If Len(Num_) > 18 Then

B_Only = InNum

Exit Function

End If

Select Case FracType

Case 1, 2

Select Case Lang

Case vArabic: Only = AOnly(Num_, FracS, Single_, Plural, Parts, Sex, Dec)

Case vEnglish: Only = EOnly(Num_, FracS, Single_, Plural, Parts, Dec)

End Select

Case 3, 4

Select Case Lang

Case vArabic: Only = AOnly(Num_, "", Single_, Plural, Parts, Sex, Dec)

If CDbl(Num_) = 0 And FracS <> "" Then Only = ""

If FracType = 3 Then And_ = "و " Else And_ = "و"

If FracS <> "" Then Only = AddAnd(Only, FracS, "", And_, CByte(Lang))

Case vEnglish: Only = EOnly(Num_, "", Single_, Plural, Parts, Dec)

If CDbl(Num_) = 0 And FracS <> "" Then Only = ""

If FracS <> "" Then Only = AddAnd(Only, FracS, "", " and", CByte(Lang))

End Select

End Select

If Only <> "" Then

Select Case Lang

'Case vArabic: B_Only = "فقط " & Only

Case vArabic: B_Only = Only & " فقط"

'Case vEnglish: B_Only = Only & " only"

Case vEnglish: B_Only = "Only " & Only

End Select

End If

End Function

Function ArbNum2Text(ByVal InNum, _

Optional ByVal DecimalPlaces = Null, _

Optional ByVal FractionType = 1, _

Optional ByVal CurrencySingle = "", _

Optional ByVal CurrencyPlural = "", _

Optional ByVal CurrencySex = 0, _

Optional ByVal FractionSingle = "", _

Optional ByVal FractionPlural = "", _

Optional ByVal FractionSex = 0) As Variant

Dim Negative As String

If IsNull(InNum) Then

ArbNum2Text = Null

Exit Function

Else

If InNum < 0 Then

InNum = Abs(InNum)

Negative = "سالب "

End If

End If

If IsNull(FractionType) Then FractionType = 1

If myNz(CurrencySingle) = Empty Or myNz(CurrencyPlural) = Empty Then

If Not IsNull(DecimalPlaces) Then

InNum = ReFormat(CDbl(InNum), CByte(DecimalPlaces))

End If

ArbNum2Text = Negative & S_Only(InNum, vArabic, CByte(FractionType))

Exit Function

End If

If IsNull(DecimalPlaces) Then DecimalPlaces = 3

If InNum <> Fix(InNum) Then

If myNz(FractionSingle) = Empty Or myNz(FractionPlural) = Empty Then

If FractionType > 2 Then FractionType = 1

End If

End If

ArbNum2Text = Negative & _

B_Only(CDbl(myNz(InNum)), vArabic, CByte(myNz(CurrencySex)), _

CByte(myNz(DecimalPlaces)), CStr(myNz(CurrencySingle)), _

CStr(myNz(CurrencyPlural)), CByte(myNz(FractionSex)), _

CStr(myNz(FractionSingle)), CStr(myNz(FractionPlural)), _

CByte(myNz(FractionType)))

'-- تعديل خاص لأحد أعضاء منتدى أوفيسنا ---------------------------------

If CStr(myNz(CurrencySingle)) = "درجة" And _

CStr(myNz(FractionSingle)) = "جزء" Then

Dim Grade As String

Dim FracS As String

Dim Pos As Integer

Grade = Negative & _

B_Only(CDbl(myNz(InNum)), vArabic, CByte(myNz(CurrencySex)), _

CByte(myNz(DecimalPlaces)), CStr(myNz(CurrencySingle)), _

CStr(myNz(CurrencyPlural)), CByte(myNz(FractionSex)), _

CStr(myNz(FractionSingle)), CStr(myNz(FractionPlural)), _

CByte(myNz(FractionType)))

Select Case CDbl(myNz(InNum)) - Fix(CDbl(myNz(InNum)))

Case 0:

Case 0.25: FracS = IIf(Fix(CDbl(myNz(InNum))) = 0, "ربع درجة فقط", "ربع فقط")

Case 0.5: FracS = IIf(Fix(CDbl(myNz(InNum))) = 0, "نصف درجة فقط", "نصف فقط")

Case 0.75: FracS = IIf(Fix(CDbl(myNz(InNum))) = 0, "ثلاثة أرباع درجة فقط", "ثلاثة أرباع فقط")

Case Else: FracS = " " & CDbl(myNz(InNum)) - Fix(CDbl(myNz(InNum))) & " فقط"

End Select

If FracS <> "" Then

Pos = InStr(1, Grade, " و ")

If Pos > 0 Then

Grade = Left(Grade, Pos + 1) & FracS

Else

Grade = FracS

End If

End If

Pos = InStr(1, Grade, "درجة واحدة")

If Pos > 0 Then Grade = Left(Grade, Pos + 4) & Mid(Grade, Pos + 11)

Pos = InStr(1, Grade, "درجتان اثنتان")

If Pos > 0 Then Grade = Left(Grade, Pos + 6) & Mid(Grade, Pos + 14)

If CDbl(myNz(InNum)) = 0 Then Grade = "صفر"

ArbNum2Text = Grade

End If

'-- نهاية التعديل -------------------------------------------------------

End Function

Function EngNum2Text(ByVal InNum, _

Optional ByVal DecimalPlaces = Null, _

Optional ByVal FractionType = 1, _

Optional ByVal CurrencySingle = "", _

Optional ByVal CurrencyPlural = "", _

Optional ByVal FractionSingle = "", _

Optional ByVal FractionPlural = "") As Variant

Dim Negative As String

If IsNull(InNum) Then

EngNum2Text = Null

Exit Function

Else

If InNum < 0 Then

InNum = Abs(InNum)

Negative = "Negative only "

Else

Negative = "Only "

End If

End If

If IsNull(FractionType) Then FractionType = 1

If myNz(CurrencyPlural) = Empty Then CurrencyPlural = CurrencySingle '& "(s)"

If myNz(FractionPlural) = Empty Then FractionPlural = FractionSingle '& "(s)"

If myNz(CurrencySingle) = Empty Then

If Not IsNull(DecimalPlaces) Then

InNum = ReFormat(CDbl(InNum), CByte(DecimalPlaces))

End If

EngNum2Text = Negative & S_Only(InNum, vEnglish, CByte(FractionType))

Exit Function

End If

If IsNull(DecimalPlaces) Then DecimalPlaces = 3

If InNum <> Fix(InNum) Then

If myNz(FractionSingle) = Empty Then

If FractionType > 2 Then FractionType = 1

End If

End If

EngNum2Text = Negative & Mid( _

B_Only(CDbl(myNz(InNum)), vEnglish, 0, _

CByte(myNz(DecimalPlaces)), CStr(myNz(CurrencySingle)), _

CStr(myNz(CurrencyPlural)), 0, _

CStr(myNz(FractionSingle)), CStr(myNz(FractionPlural)), _

CByte(myNz(FractionType))), 6)

End Function


Option Explicit

Public Const vArabic As Byte = 1

Public Const vEnglish As Byte = 2

Public Const vMale As Byte = 0

Public Const vFemale As Byte = 1

Private Function myNz(ByVal InValue, Optional ByVal ValueIfNull = Null)

  myNz = IIf(IsNull(InValue), IIf(IsNull(ValueIfNull), Empty, ValueIfNull), InValue)

End Function

Private Function Delete(S As String, Index As Integer, Count As Integer) As String

  Delete = Left(S, Index - 1) + _

		   Mid(S, Index + Count, Len(S))

End Function

Private Function Insert(Source, S As String, Index As Integer) As String

  Dim LPart As String

  Dim RPart As String


  LPart = Left(S, Index - 1)

  RPart = Mid(S, Index, Len(S))

  Insert = LPart & Source & RPart

End Function

Private Function AddAnd(s1 As String, S2 As String, S3 As String, _

					    And_ As String, Lang As Byte) As String

  Dim InAnd_   As String

  Dim CollectS As String


  If Lang = vArabic Then InAnd_ = " " + And_ Else InAnd_ = And_ + " "

  If (s1 <> "") And (S2 <> "") Then And_ = InAnd_ Else And_ = ""

  CollectS = s1 + And_ + S2

  If (CollectS <> "") And (S3 <> "") Then And_ = InAnd_ Else And_ = ""

  AddAnd = CollectS + And_ + S3

End Function

Private Function S2Double(Single_ As Variant, Sex As Byte) As String

  Dim LLeter As Integer

  Dim K	  As Byte

  Dim Sngl_1 As String

  Dim Sngl_2 As String


  K = InStr(1, Single_ & " ", " ")

  Sngl_1 = Left(Single_, K - 1)

  Sngl_2 = ""

  If K < Len(Single_) Then

    Sngl_2 = Mid(Single_, K + 1, Len(Single_))

  End If


  If Sngl_2 <> "" Then

    If Right(Sngl_2, 1) = "ة" Then

	  Sngl_2 = Left(Sngl_2, Len(Sngl_2) - 1) & "تان"

    Else

	  Sngl_2 = Sngl_2 & "ان"

    End If

  End If


  If Sngl_1 <> "" Then LLeter = Asc(Right(Sngl_1, 1))


  Select Case LLeter

    Case 201 ' "ة"

	  Sngl_1 = Left(Sngl_1, Len(Sngl_1) - 1) & "تان"

    Case 236 ' "ى"

	  Sngl_1 = Left(Sngl_1, Len(Sngl_1) - 1) & "يان"

    Case 199 ' "ا"

	  Sngl_1 = Left(Sngl_1, Len(Sngl_1) - 1) & "وان"

    Case 193 ' "ء"

	  If Right(Sngl_1, 2) = "اء" Then

	    If Sex = 1 Then

		  Sngl_1 = Left(Sngl_1, Len(Sngl_1) - 1) & "وان"

	    Else

		  Sngl_1 = Sngl_1 & "ان"

	    End If

	  End If

    Case Else

	  If Sngl_1 <> "" Then Sngl_1 = Sngl_1 & "ان"

  End Select


  If Sngl_2 <> "" Then

    S2Double = Sngl_1 & " " & Sngl_2

  Else

    S2Double = Sngl_1

  End If

End Function

Private Function Fmale(Num As Byte, Sex As Byte, Female()) As String

  Dim Two(1 To 4) As String

  Dim InSex As Byte


  Two(1) = "أحد"

  Two(2) = "اثنان"

  Two(3) = "إحدى"

  Two(4) = "ة"


  Select Case Sex

    Case vMale:

	  Select Case Num

	    Case 1:			 Fmale = Mid(Female(1), 1, 4)

	    Case 2:			 Fmale = Two(2)

	    Case 8:			 Fmale = Female(Num) + "ي" + Two(4)

	    Case 3 To 7, 9, 10: Fmale = Female(Num) + Two(4)

	    Case 11:		    Fmale = Two(1) + " " + Female(10)

	    Case 12:		    Fmale = Mid(Two(2), 1, 4) + " " + Female(10)

	    Case 13 To 19:	  Fmale = Female(Num - 10) + Two(4) + " " + Female(10)

	  End Select

    Case vFemale:

	  Select Case Num

	    Case 1 To 10:	   Fmale = Female(Num)

	    Case 11:		    Fmale = Two(3) + " " + Female(10) + Two(4)

	    Case 12:		    Fmale = Mid(Female(2), 1, 5) + " " + Female(10) + Two(4)

	    Case 13 To 19:	  Fmale = Female(Num - 10) + " " + Female(10) + Two(4)

	  End Select

    End Select

End Function

Private Function Tens(Num As Byte, Female()) As String

  Const Noon = "ون"


  Select Case Num

    Case 2:	  Tens = Female(10) + Noon

    Case 3 To 9: Tens = Female(Num) + Noon

  End Select

End Function

Private Function Hunds(Num As Byte, Female()) As String

  Const Hund = "مائة"


  Select Case Num

    Case 1:	  Hunds = Hund

    Case 2:	  Hunds = Mid(Hund, 1, 3) + Mid(Female(2), 4, 3)

    Case 3 To 9: Hunds = Female(Num) + Hund

   End Select

End Function

Private Function Tenteen(Num As Byte, ETens()) As String

  Const een = "een"


  Num = Num Mod 10

  Select Case Num

    Case 3 To 9:

	  Tenteen = Mid(ETens(Num), 1, Len(ETens(Num)) - 1) + een

  End Select

End Function

Private Function EHunds(Num As Byte, ESingle()) As String

  EHunds = ESingle(Num) + " hundred"

End Function

Private Function ReFormat(InNum As Double, Dec As Byte) As Double

  Dim NewFormat As String


  If Dec > 0 Then NewFormat = "0." Else NewFormat = "0"

  NewFormat = NewFormat & String(Dec, "0")

  ReFormat = Format(InNum, NewFormat)

End Function

Private Function ReStr(InNum As String) As String

  Dim K As Byte

  Dim Digits As Byte

  Dim Num_ As String


  Num_ = LTrim(InNum)

  K = InStr(1, Num_, "E+", 1)

  If K > 0 Then

    Digits = Val(Mid(Num_, K + 2, 3))

    Num_ = Left(Num_, K - 1)

    Num_ = Delete(Num_, 2, 1)

    Do While Len(Num_) - 1 < Digits

	  Num_ = Insert(Num_, "0", 1)

    Loop

  End If

  ReStr = Num_

End Function

Private Function AOnly(Num_ As String, FracS As String, Single_ As String, _

					   Plural As String, Parts As Byte, Sex As Byte, Dec As Byte) As String

  Const And_ As String * 1 = "و"

  Const Lang = vArabic

  Dim PartNum(0 To 5) As Long

  Dim Result1(0 To 5) As String

  Dim Parts_(0 To 11) As String

  Dim Female(1 To 10) As Variant

  Dim TempI		   As Byte

  Dim Sex2		    As Byte

  Dim K			   As Byte

  Dim Only_		   As String

  Dim OnlyPart	    As String

  Dim Part_		   As String

  Dim TempS		   As String

  Dim Sngl_1		  As String

  Dim Sngl_2		  As String

  Dim N1  As Byte, N2    As Byte, N3    As Byte

  Dim N1_ As String, N2_ As String, N3_ As String


  If Val(Num_) = 0 Then

    If FracS = "" Then

	  AOnly = RTrim("صفر " & Single_)

    Else

	  AOnly = FracS & " " & Single_

    End If

    Exit Function

  End If


  Female(1) = "واحدة"

  Female(2) = "اثنتان"

  Female(3) = "ثلاث"

  Female(4) = "أربع"

  Female(5) = "خمس"

  Female(6) = "ست"

  Female(7) = "سبع"

  Female(8) = "ثمان"

  Female(9) = "تسع"

  Female(10) = "عشر"


  Parts_(0) = ""

  Parts_(1) = "ألف"

  Parts_(2) = "مليون"

  Parts_(3) = "مليار"

  Parts_(4) = "ترليون"

  Parts_(5) = "كدرليون"

  Parts_(6) = ""

  Parts_(7) = "آلاف"

  Parts_(8) = "ملايين"

  Parts_(9) = "مليارات"

  Parts_(10) = "ترليونات"

  Parts_(11) = "كدرليونات"


  K = InStr(1, Single_ & " ", " ")

  Sngl_1 = Left(Single_, K - 1)

  Sngl_2 = ""

  If K < Len(Single_) Then

    Sngl_2 = Mid(Single_, K + 1, Len(Single_))

  End If


  For K = 0 To Parts - 1

    PartNum(K) = Val(Mid(Num_, (K * 3) + 1, 3))

  Next K


    Sex2 = Sex

    For K = 0 To (Parts - 1)

	  If K = (Parts - 1) Then Sex = Sex2 Else Sex = vMale

	  TempS = Mid(Num_, (K * 3) + 1, 3)

	  TempI = Val(Mid(TempS, 2, 2))

	  N1 = Val(Mid(TempS, 1, 1))

	  N2 = Val(Mid(TempS, 2, 1))

	  N3 = Val(Mid(TempS, 3, 1))

	  '{------------------------------------------}

	  N1_ = "": N2_ = "": N3_ = ""

	  If N1 > 0 Then N1_ = Hunds(CByte(N1), Female())

	  If PartNum(K) = 200 Then N1_ = Mid(N1_, 1, Len(N1_) - 1)

	  Select Case TempI

	    Case 1 To 2:

		  If K = Parts - 1 Then If FracS <> "" Then N3_ = Fmale(N3, CByte(Sex), Female())  'Sex

	    Case 3 To 19:

		  N3_ = Fmale(TempI, CByte(Sex), Female())

	    Case 20 To 99:

		  N2_ = Tens(CByte(N2), Female())

		  If N3 > 0 Then N3_ = Fmale(N3, CByte(Sex), Female())

		  If (N3 Mod 10 = 1) And (Sex = vFemale) Then N3_ = "إحدى"

	  End Select

	  OnlyPart = AddAnd(N1_, N3_, N2_, And_, Lang)

	  '{------------------------------------------}

	  If PartNum(K) > 100 Then

	    Select Case TempI

		  Case 1, 2:

		    OnlyPart = AddAnd(OnlyPart, Parts_(Parts - K - 1), "", "", Lang)

	    End Select

	  End If

	  '{------------------------------------------}

	  Part_ = ""

	  If PartNum(K) > 0 Then

	    Part_ = Parts_(Parts - K - 1)

	    If Part_ <> "" Then

		  Select Case TempI

		    Case 2:	    Part_ = Part_ + "ان"

		    Case 3 To 10:  Part_ = Parts_((Parts - K - 1) + 6)

		    Case 11 To 99: Part_ = Part_ + "ا"

		  End Select

	    End If

	  End If

	  '{------------------------------------------}

	  If Part_ <> "" Then

	    If TempI >= 1 And TempI <= 2 Then

		   OnlyPart = AddAnd(OnlyPart, Part_, "", And_, Lang)

	    Else

		  OnlyPart = AddAnd(OnlyPart, Part_, "", "", Lang)

	    End If

	  End If

	  Result1(K) = (OnlyPart)

    Next K

    '{------------------------------------------}

    N1_ = AddAnd(Result1(0), Result1(1), Result1(2), And_, Lang)

    N2_ = AddAnd(Result1(3), Result1(4), Result1(5), And_, Lang)

    Only_ = AddAnd(N1_, N2_, "", And_, Lang)

    If FracS <> "" Then

	  If Only_ <> "" Then FracS = " " + FracS

	  Only_ = AddAnd(Only_, FracS, "", And_, Lang)

    End If

    If Only_ <> "" Then

	  If Mid(Only_, Len(Only_), 1) = "ا" Then

	    If Mid(Only_, Len(Only_) - 1, 2) <> "تا" Then

		  Only_ = Mid(Only_, 1, Len(Only_) - 1)

	    End If

	  End If

	  If TempS = "000" Then

	    If Mid(Only_, Len(Only_) - 1, 2) = "ان" Then

		  Only_ = Mid(Only_, 1, Len(Only_) - 1)

	    End If

	  End If

    End If

    '{------------------------------------------}

    If FracS = "" Then

	  Select Case TempI

	    Case 0: If Only_ <> "" Then Only_ = AddAnd(Only_, Single_, "", "", Lang)

	    Case 1: Only_ = AddAnd(Only_, AddAnd(Single_, Fmale(1, CByte(Sex), Female()), "", "", Lang), "", And_, Lang)

	    Case 2: Only_ = AddAnd(Only_, AddAnd(S2Double(Single_, CByte(Sex)), Fmale(2, CByte(Sex), Female()), "", "", Lang), "", And_, Lang)

	    Case 3 To 10:

		  If Sngl_2 <> "" Then

		    If Right(Sngl_2, 1) = "ة" Then

			  Only_ = AddAnd(Only_, Plural, Sngl_2, "", Lang)

		    Else

			  Only_ = AddAnd(Only_, Plural, Sngl_2 & "ة", "", Lang)

		    End If

		  Else

		    Only_ = AddAnd(Only_, Plural, "", "", Lang)

		  End If

	    Case 11 To 99:

		  If Sngl_1 <> "" Then

		    Only_ = AddAnd(Only_, Sngl_1, "", "", Lang)

		    N1_ = Mid(Only_, Len(Only_), 1)

		    Select Case N1_

			  Case "ة", "ى", "ا"

			  Case Else

			    Only_ = Only_ + "ا"

		    End Select

		    N1_ = Mid(Only_, Len(Only_) - 2, 3)

		    'هذا الشرط لحل مشكلة عدم التمييز بين "ء" و "ل" 2002/08/24

		    If N1_ = "اءا" And Asc(Right(Sngl_1, 1)) = 193 Then

			  Only_ = Left(Only_, Len(Only_) - 1)

		    End If

		    If Sngl_2 <> "" Then

			  If Right(Only_, 1) = "ا" Then

			    Only_ = AddAnd(Only_, Sngl_2 & "ا", "", "", Lang)

			  Else

			    Only_ = AddAnd(Only_, Sngl_2, "", "", Lang)

			  End If

		    Else

			  Only_ = AddAnd(Only_, Sngl_2, "", "", Lang)

		    End If

		  End If

	  End Select

    Else

	  Only_ = AddAnd(Only_, Sngl_1, Sngl_2, "", Lang)

    End If

    AOnly = (Only_)

End Function

Private Function EOnly(Num_ As String, FracS As String, Single_ As String, _

					   Plural As String, Parts As Byte, Dec As Byte) As String

  Const Lang = vEnglish

  Dim ESingle(1 To 12) As Variant

  Dim ETens(2 To 9)    As Variant

  Dim EParts_(0 To 5)  As String

  Dim PartNum(0 To 5)  As Long

  Dim Result1(0 To 5)  As String

  Dim TempS		    As String

  Dim TempI		    As Byte

  Dim Sex2			 As Byte

  Dim OnlyPart		 As String

  Dim Part_		    As String

  Dim Only_		    As String

  Dim Leng			 As Integer

  Dim K			    As Integer

  Dim N1  As Byte, N2    As Byte, N3    As Byte

  Dim N1_ As String, N2_ As String, N3_ As String


  If Val(Num_) = 0 Then

    If FracS = "" Then

	 'EOnly = LTrim(Single_ & " zero")

	  EOnly = RTrim("zero " & Single_)

    Else

	  EOnly = Single_ & " " & FracS

    End If

    Exit Function

  End If


  ESingle(1) = "one"

  ESingle(2) = "two"

  ESingle(3) = "three"

  ESingle(4) = "four"

  ESingle(5) = "five"

  ESingle(6) = "six"

  ESingle(7) = "seven"

  ESingle(8) = "eight"

  ESingle(9) = "nine"

  ESingle(10) = "ten"

  ESingle(11) = "eleven"

  ESingle(12) = "twelve"


  ETens(2) = "twenty"

  ETens(3) = "thirty"

  ETens(4) = "forty"

  ETens(5) = "fifty"

  ETens(6) = "sixty"

  ETens(7) = "seventy"

  ETens(8) = "eighty"

  ETens(9) = "ninety"


  EParts_(0) = ""

  EParts_(1) = "thousund"

  EParts_(2) = "million"

  EParts_(3) = "billion"

  EParts_(4) = "trillion"

  EParts_(5) = "quadrillion"


  For K = 0 To Parts - 1

    PartNum(K) = Val(Mid(Num_, (K * 3) + 1, 3))

  Next K


  For K = 0 To (Parts - 1)

    TempS = Mid(Num_, (K * 3) + 1, 3)

    TempI = Val(Mid(TempS, 2, 2))

    N1 = Val(Mid(TempS, 1, 1))

    N2 = Val(Mid(TempS, 2, 1))

    N3 = Val(Mid(TempS, 3, 1))

    '{------------------------------------------}

    N1_ = "": N2_ = "": N3_ = ""

    If N1 > 0 Then N1_ = EHunds(CByte(N1), ESingle())

    Select Case TempI

	  Case 1 To 12:  N3_ = ESingle(TempI)

	  Case 13 To 19: If N3 > 0 Then N3_ = Tenteen(CByte(TempI), ETens())

	  Case 20 To 99:

	    N2_ = ETens(N2)

	    If N3 > 0 Then

		  N3_ = N2_ + "-" + ESingle(N3)

		  N2_ = ""

	    End If

    End Select

    OnlyPart = AddAnd(N1_, N2_, N3_, "", Lang)

    '{------------------------------------------}

    Part_ = ""

    If PartNum(K) > 0 Then

	  Part_ = EParts_(Parts - K - 1)

	  If Part_ <> "" Then Part_ = EParts_((Parts - K - 1))

    End If

    Result1(K) = AddAnd(OnlyPart, Part_, "", "", Lang)

  Next K

  '{------------------------------------------}

  N1_ = AddAnd(Result1(0), Result1(1), Result1(2), "", Lang)

  N2_ = AddAnd(Result1(3), Result1(4), Result1(5), "", Lang)

  Only_ = AddAnd(N1_, N2_, "", "", Lang)

  Leng = Len(Only_)

  Only_ = AddAnd(Only_, FracS, "", " and", Lang)

  If Only_ <> "" Then

   'Only_ = AddAnd(Single_, Only_, "", "", Lang)

    If Val(Num_) = 1 Then

	  Only_ = AddAnd(Only_, Single_, "", "", Lang)

    Else

	  Only_ = AddAnd(Only_, Plural, "", "", Lang)

    End If

    EOnly = Only_

  End If

End Function

Private Function S_Only(InNum As Variant, Lang As Byte, FracType As Byte) As Variant

  Dim Num_  As String

  Dim K	 As Byte

  Dim Dec   As Byte

  Dim FType As Byte


  If IsNull(InNum) Then

    S_Only = Null

    Exit Function

  End If


  Num_ = Str(InNum)

  K = InStr(1, Num_, ".", 1)

  If K > 0 Then

    Dec = Len(Num_) - K

    If Dec < 2 Then Dec = 2

  Else

   Dec = 0

  End If


  FType = FracType

  If FType <> 2 Then FType = 1


  S_Only = B_Only(InNum, Lang, 0, Dec, "", "", 0, "", "", FType)

End Function


Private Function B_Only(InNum As Variant, Lang As Byte, Sex As Byte, Dec As Byte, _

					    Single_ As String, Plural As String, _

					    FSex As Byte, SFrac As String, PFrac As String, _

					    FracType As Byte) As Variant

  Dim Leng    As Byte

  Dim Parts   As Byte

  Dim K	   As Byte

  Dim FracVal As Double

  Dim Num_    As String

  Dim FracS   As String

  Dim FracNum As String

  Dim Only    As String

  Dim And_    As String


  If IsNull(InNum) Then

    B_Only = Null

    Exit Function

  End If


  Num_ = Str(InNum)

  If InStr(1, Num_, "E+", 1) > 0 Then

    Num_ = ReStr(Num_)

    FracVal = 0

    GoTo DoProcess

  End If


  Num_ = ReFormat(Val(InNum), Dec)

  K = InStr(1, Num_, ".", 1)

  If K > 0 Then FracS = "0" & Mid(Num_, K, Dec + 1) Else FracS = ""

  FracVal = Val(FracS)

  Num_ = Trim(Str(Fix(InNum)))


  Do While Len(FracS) < Dec + 2

    FracS = Insert(FracS, "0", 1)

  Loop

DoProcess:

  If FracVal = 0 Then FracS = ""

  FracNum = Trim(Mid(FracS, 3, Len(FracS)))

  If FracS <> "" Then

    Select Case FracType

	  Case 2

	    Select Case Lang

		  Case vArabic:  FracS = "1" & String(Dec, "0") & "/" & CDbl(Format(FracNum, String(Dec, "0")))

		  Case vEnglish: FracS = CDbl(Format(FracNum, String(Dec, "0"))) & "/" & "1" & String(Dec, "0")

	    End Select

	  Case 3

	    FracS = CLng(FracNum) & " " & SFrac

	    'If Lang = vEnglish And CDbl(FracNum) > 1 Then FracS = FracS & "(s)"

	  Case 4

	    Leng = Len(FracNum)

	    Parts = Fix((Leng + 2) / 3)

	    For K = 1 To (Parts * 3) - Leng

		  FracNum = Insert("0", FracNum, 1)

	    Next K

	    Select Case Lang

		  Case vArabic:  FracS = AOnly(FracNum, "", SFrac, PFrac, Parts, FSex, FracType)

		  Case vEnglish: 'FracS = EOnly(FracNum, "", "", "", Parts, 0) & " " & SFrac

						  FracS = EOnly(FracNum, "", SFrac, PFrac, Parts, 0) '& " " & SFrac

						 'If CDbl(FracNum) > 1 Then FracS = FracS & "(s)"

	    End Select

    End Select

  End If


  Leng = Len(Num_)

  Parts = Fix((Leng + 2) / 3)


  For K = 1 To (Parts * 3) - Leng

    Num_ = Insert("0", Num_, 1)

  Next K


  If Len(Num_) > 18 Then

    B_Only = InNum

    Exit Function

  End If

  Select Case FracType

    Case 1, 2

	  Select Case Lang

	    Case vArabic:  Only = AOnly(Num_, FracS, Single_, Plural, Parts, Sex, Dec)

	    Case vEnglish: Only = EOnly(Num_, FracS, Single_, Plural, Parts, Dec)

	  End Select

    Case 3, 4

	  Select Case Lang

	    Case vArabic:  Only = AOnly(Num_, "", Single_, Plural, Parts, Sex, Dec)

					   If CDbl(Num_) = 0 And FracS <> "" Then Only = ""

					   If FracType = 3 Then And_ = "و " Else And_ = "و"

					   If FracS <> "" Then Only = AddAnd(Only, FracS, "", And_, CByte(Lang))

	    Case vEnglish: Only = EOnly(Num_, "", Single_, Plural, Parts, Dec)

					   If CDbl(Num_) = 0 And FracS <> "" Then Only = ""

					   If FracS <> "" Then Only = AddAnd(Only, FracS, "", " and", CByte(Lang))

	  End Select

  End Select


  If Only <> "" Then

    Select Case Lang

	 'Case vArabic:  B_Only = "فقط " & Only

	  Case vArabic:  B_Only = Only & " فقط"

	 'Case vEnglish: B_Only = Only & " only"

	  Case vEnglish: B_Only = "Only " & Only

    End Select

  End If

End Function

Function ArbNum2Text(ByVal InNum, _

		    Optional ByVal DecimalPlaces = Null, _

		    Optional ByVal FractionType = 1, _

		    Optional ByVal CurrencySingle = "", _

		    Optional ByVal CurrencyPlural = "", _

		    Optional ByVal CurrencySex = 0, _

		    Optional ByVal FractionSingle = "", _

		    Optional ByVal FractionPlural = "", _

		    Optional ByVal FractionSex = 0) As Variant


  Dim Negative As String


  If IsNull(InNum) Then

    ArbNum2Text = Null

    Exit Function

  Else

    If InNum < 0 Then

	  InNum = Abs(InNum)

	  Negative = "سالب "

    End If

  End If


  If IsNull(FractionType) Then FractionType = 1


  If myNz(CurrencySingle) = Empty Or myNz(CurrencyPlural) = Empty Then

    If Not IsNull(DecimalPlaces) Then

	  InNum = ReFormat(CDbl(InNum), CByte(DecimalPlaces))

    End If

    ArbNum2Text = Negative & S_Only(InNum, vArabic, CByte(FractionType))

    Exit Function

  End If


  If IsNull(DecimalPlaces) Then DecimalPlaces = 3

  If InNum <> Fix(InNum) Then

    If myNz(FractionSingle) = Empty Or myNz(FractionPlural) = Empty Then

	  If FractionType > 2 Then FractionType = 1

    End If

  End If


  ArbNum2Text = Negative & _

			    B_Only(CDbl(myNz(InNum)), vArabic, CByte(myNz(CurrencySex)), _

					   CByte(myNz(DecimalPlaces)), CStr(myNz(CurrencySingle)), _

					   CStr(myNz(CurrencyPlural)), CByte(myNz(FractionSex)), _

					   CStr(myNz(FractionSingle)), CStr(myNz(FractionPlural)), _

					   CByte(myNz(FractionType)))


  '-- تعديل خاص لأحد أعضاء منتدى أوفيسنا ---------------------------------

  If CStr(myNz(CurrencySingle)) = "درجة" And _

	 CStr(myNz(FractionSingle)) = "جزء" Then


    Dim Grade As String

    Dim FracS As String

    Dim Pos As Integer


    Grade = Negative & _

		    B_Only(CDbl(myNz(InNum)), vArabic, CByte(myNz(CurrencySex)), _

				   CByte(myNz(DecimalPlaces)), CStr(myNz(CurrencySingle)), _

				   CStr(myNz(CurrencyPlural)), CByte(myNz(FractionSex)), _

				   CStr(myNz(FractionSingle)), CStr(myNz(FractionPlural)), _

				   CByte(myNz(FractionType)))


    Select Case CDbl(myNz(InNum)) - Fix(CDbl(myNz(InNum)))

	  Case 0:

	  Case 0.25: FracS = IIf(Fix(CDbl(myNz(InNum))) = 0, "ربع درجة فقط", "ربع فقط")

	  Case 0.5:  FracS = IIf(Fix(CDbl(myNz(InNum))) = 0, "نصف درجة فقط", "نصف فقط")

	  Case 0.75: FracS = IIf(Fix(CDbl(myNz(InNum))) = 0, "ثلاثة أرباع درجة فقط", "ثلاثة أرباع فقط")

	  Case Else: FracS = " " & CDbl(myNz(InNum)) - Fix(CDbl(myNz(InNum))) & " فقط"

    End Select


    If FracS <> "" Then

	  Pos = InStr(1, Grade, " و ")

	  If Pos > 0 Then

	    Grade = Left(Grade, Pos + 1) & FracS

	  Else

	    Grade = FracS

	  End If

    End If


    Pos = InStr(1, Grade, "درجة واحدة")

    If Pos > 0 Then Grade = Left(Grade, Pos + 4) & Mid(Grade, Pos + 11)

    Pos = InStr(1, Grade, "درجتان اثنتان")

    If Pos > 0 Then Grade = Left(Grade, Pos + 6) & Mid(Grade, Pos + 14)

    If CDbl(myNz(InNum)) = 0 Then Grade = "صفر"

    ArbNum2Text = Grade

  End If

  '-- نهاية التعديل -------------------------------------------------------


End Function

Function EngNum2Text(ByVal InNum, _

		    Optional ByVal DecimalPlaces = Null, _

		    Optional ByVal FractionType = 1, _

		    Optional ByVal CurrencySingle = "", _

		    Optional ByVal CurrencyPlural = "", _

		    Optional ByVal FractionSingle = "", _

		    Optional ByVal FractionPlural = "") As Variant

  Dim Negative As String


  If IsNull(InNum) Then

    EngNum2Text = Null

    Exit Function

  Else

    If InNum < 0 Then

	  InNum = Abs(InNum)

	  Negative = "Negative only "

    Else

	  Negative = "Only "

    End If

  End If


  If IsNull(FractionType) Then FractionType = 1

  If myNz(CurrencyPlural) = Empty Then CurrencyPlural = CurrencySingle '& "(s)"

  If myNz(FractionPlural) = Empty Then FractionPlural = FractionSingle '& "(s)"


  If myNz(CurrencySingle) = Empty Then

    If Not IsNull(DecimalPlaces) Then

	  InNum = ReFormat(CDbl(InNum), CByte(DecimalPlaces))

    End If

    EngNum2Text = Negative & S_Only(InNum, vEnglish, CByte(FractionType))

    Exit Function

  End If


  If IsNull(DecimalPlaces) Then DecimalPlaces = 3

  If InNum <> Fix(InNum) Then

    If myNz(FractionSingle) = Empty Then

	  If FractionType > 2 Then FractionType = 1

    End If

  End If


  EngNum2Text = Negative & Mid( _

			    B_Only(CDbl(myNz(InNum)), vEnglish, 0, _

					   CByte(myNz(DecimalPlaces)), CStr(myNz(CurrencySingle)), _

					   CStr(myNz(CurrencyPlural)), 0, _

					   CStr(myNz(FractionSingle)), CStr(myNz(FractionPlural)), _

					   CByte(myNz(FractionType))), 6)

End Function

MAHMOUD ALI YOUSSEF · نوفمبر 6, 2011

السلام عليكم

ممكن ترفق ملف

حتي نقوم بعمل المطلوب عليه وشكرا :fff: :fff: :fff:

الحامد الشاكر · نوفمبر 6, 2011

الأخوة الكرام كيف يمكن إضافة الكود إلى ملف وورد

ابو خالد التقني · سبتمبر 22, 2014

شكرا لكم جميعا

جزاكم الله كل خير

تسجيل الدخول

( موضوع مميز )دالة التفقيط

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

جوده

زائر

سالم شباني

زائر

يوسف عطا

يوسف عطا

MAHMOUD ALI YOUSSEF

الحامد الشاكر

ابو خالد التقني

Join the conversation

تصفح هذا الموضوع مؤخراً 0 اعضاء متواجدين الان

تصفح الموقع

تصفح جديد الموقع

Support

Important Information