jalal030 قام بنشر نوفمبر 5, 2011 قام بنشر نوفمبر 5, 2011 السلام عليكم ورحمة الله وبركاته ارجو تزودي بطريقة تثبيت دالة : ArbNum2Text مع شرح لكيفية عملها ولكم تحياتي
هشام شلبى قام بنشر نوفمبر 5, 2011 قام بنشر نوفمبر 5, 2011 السلام عليكم ======== شاهد هذا الرابط http://www.officena.net/ib/index.php?showtopic=29117
يوسف عطا قام بنشر نوفمبر 6, 2011 قام بنشر نوفمبر 6, 2011 بص يا عم جلال أولاً كل سنة ونت طيب ثانياً بالنسبة للدالة المقصودة لابد أولاً من وضع الدالة فى موديول فى الملف المراد تطبيقها فيه والدالة التالية أحد أعمال أخونا الغالى مساه الله بالخير أبوهادى إنسخها الأول فى موديول بالملف وكمل معايا الشرح بعد كدة '-- äÓÎÉ ÎÇÕÉ áÃÍÏ ÃÚÖÇÁ ãäÊÏì ÃæÝíÓäÇ ¡ ÇáÑÌÇÁ ÚÏã ÇÓÊÎÏÇãåÇ ãä ÞÈá ÇáÂÎÑíä '-- 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 قام بنشر نوفمبر 6, 2011 قام بنشر نوفمبر 6, 2011 السلام عليكم ممكن ترفق ملف وتوضح المطلوب حتي نستظيع عمل الازم لك وكل عام وانتم بخير :fff:
الردود الموصى بها
Join the conversation
You can post now and register later. If you have an account, sign in now to post with your account.