اذهب الي المحتوي
أوفيسنا

دالة : ArbNum2Text

jalal030

بواسطه jalal030
في منتدى الاكسيل Excel

 مشاركة

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

يوسف عطا

يوسف عطا

قام بنشر
قام بنشر

بص يا عم جلال

أولاً كل سنة ونت طيب

ثانياً بالنسبة للدالة المقصودة

لابد أولاً من وضع الدالة فى موديول فى الملف المراد تطبيقها فيه

والدالة التالية أحد أعمال أخونا الغالى مساه الله بالخير أبوهادى

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


'-- äÓÎÉ ÎÇÕÉ áÃÍÏ ÃÚÖÇÁ ãäÊÏì ÃæÝíÓäÇ ¡ ÇáÑÌÇÁ ÚÏã ÇÓÊÎÏÇãåÇ ãä ÞÈá ÇáÂÎÑíä

'-- 21/07/2004

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

بعد كدة تضغط أيقونة إدراج دالة

دوال معرفة عن طريق المستخدم

هاتلاقى دالتين العربية والإنجليزية

طبعاً هنختار العربية

هايتفتحلنا صندوق العمل على الدالة

أول سطر هانختار خلية الرقم المراد تفقيطه

السطور التالية بالترتيب هانكتب فيها التالى

2

3

درجة

درجات

1

جزء

أجزاء

1

طبعاً الكلمات العربية هانحطها بين علامات تنصيص"الكلمة"

بعد كدة هاتعمل دراج لأسفل للخلية التى وضعت فيها الدالة

وإن شاء الله أكون وفقت فى الشرح

رابط هذا التعليق
شارك
MAHMOUD ALI YOUSSEF

MAHMOUD ALI YOUSSEF

قام بنشر
قام بنشر

السلام عليكم

ممكن ترفق ملف وتوضح المطلوب

حتي نستظيع عمل الازم لك

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

رابط هذا التعليق
شارك

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.

×
 مشاركة
الذهاب الي قائمه المواضيع
×
×
  • اضف...

Important Information

  I accept