ناصر سعيد

لن اجد افضل من هذا الرد أحسنت استاذ عبد اللطيف بارك الله فيك وزادك الله من فضله ورحم الله والديك وماذا نفعل اذا كانت للصفحات باسوورد ونسيناها ؟

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

ربنا يطمنا عليك دائما استاذ الاساتذه عبد الله باقشير

اولا يحفظك الرحمن لرقه ردك المكتبه العربيه تفتقد مثل هذا العمل .. فندعو الله ان تجد الوقت المناسب لعمل هذا الملف ولو بفكره جديده مره تانيه ربنا يبارك فيك

رايت عوده الجهبذ عادل حنفي صاحب الكود الاصلي لهذا العمل ولذلك نتعشم في الله اولا ثم في الاستاذ عادل لتنقيح الملف السابق له بالمستجدات الجديده وله من الله الجزاء الطيب ان شاء الله

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 Function Delete(S As String, Index, Count As Integer) As String Delete = Left(S, Index - 1) + _ Mid(S, Index + Count, Len(S)) End Function Function Insert(Source, S As String, Index As Integer) As String Dim LPart, RPart As String LPart = Left(S, Index - 1) RPart = Mid(S, Index, Len(S)) Insert = LPart & Source & RPart End Function Function AddAnd(S1, S2, S3, And_ As String, Lang As Byte) As String Dim InAnd_, 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 Function Fmale(NUM, 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 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 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 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 Function EHunds(NUM As Byte, ESingle()) As String EHunds = ESingle(NUM) + " hundred" End Function Function ReFormat(InNum As Double, dec As Byte) As Double Dim NewFormat As String Dim K As Byte If dec > 0 Then NewFormat = "0." Else NewFormat = "0" For K = 1 To dec NewFormat = NewFormat + "0" Next K ReFormat = Format(InNum, NewFormat) End Function Function ReStr(InNum As String) As String Dim K, 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 Function AOnly(Num_, FracS, Single_, Double_, Ploral_ As String, Parts, sex, 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 N1, N2, N3, TempI, Sex2, K As Byte Dim Only_ As String Dim OnlyPart As String Dim N1_, N2_ As String Dim N3_ As String Dim Part_ As String Dim TempS As String Dim Female(1 To 10) As Variant Dim Parts_(0 To 11) As String If Val(Num_) = 0 Then AOnly = RTrim("فقط صفر " & Single_) 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) = "كدرليونات" 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(Double_, Fmale(2, CByte(sex), Female()), "", "", Lang), "", And_, Lang) Case 3 To 10: Only_ = AddAnd(Only_, Ploral_, "", "", Lang) Case 11 To 99: If Single_ <> "" Then Only_ = AddAnd(Only_, Single_, "", "", 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/02/15 If N1_ = "اءا" And Single_ <> "ريال" Then Only_ = Left(Only_, Len(Only_) - 1) End If End If End Select Else Only_ = AddAnd(Only_, Single_, "", "", Lang) End If If Only_ <> "" Then Only_ = "فقط " + Only_ AOnly = (Only_) End Function Function EOnly(Num_, FracS, Single_ As String, Parts, 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 TempS As String Dim N1, N2, N3, TempI, Sex2 As Byte Dim N1_, N2_, N3_ As String Dim OnlyPart, Part_, Only_ As String Dim Leng, K As Integer Dim PartNum(0 To 5) As Long Dim Result1(0 To 5) As String If Val(Num_) = 0 Then EOnly = LTrim(Single_ & " zero only") 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) = "fourty" 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 Only_ <> "" Then Only_ = Only_ + " only" EOnly = Only_ End If End Function Function S_Only(InNum As Variant, Lang As Byte) As Variant Dim Num_ As String Dim K, dec 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 S_Only = B_Only(InNum, Lang, 0, dec, "", "", "") End Function Function B_Only(InNum As Variant, Lang, sex, dec As Byte, Single_, Double_, Ploral_ As String) As Variant Dim Leng, Parts, K As Byte Dim FracVal As Double Dim Num_ As String Dim FracS 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 = "" 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 Lang Case vArabic: B_Only = AOnly(Num_, FracS, Single_, Double_, Ploral_, Parts, sex, dec) Case vEnglish: B_Only = EOnly(Num_, FracS, Single_ + "", Parts, dec) End Select End Function Sub Test() 'اللغة 1=عربي 2=انجليزي ' الجنس 0=مذكر 1=مؤنث 'الدالة الأولى 'المدخلات الرقم واللغة MsgBox S_Only(1500, vArabic) '-------------------------------------------------- 'الدالة الثالثة '"المدخلات الرقم واللغة والجنس وطول الكسر و "مفرد،مثنى،جمع المعدود MsgBox B_Only(1500, vArabic, vMale, 2, "درجة", "درجتان", "درجات") End Sub هذا هو الكود المستخدم بارك الله لكم

جزاك الله كل خير وبارك الله لك

للرد .. من فضلكم

============ اولا يجزيك الله كل خير وبعد : 1- الدخول الى محرر الاكواد - 2-اختيار Tools 3- تظهر قائمة اختر منها reference .... ولكتها باهته لايمكن الاستفاده منها والصوره توضح

===== رساله_خطا.bmp 2.25 \

بسم الله الرحمن الرحيم كل عام وحضراتكم بخير تظهر هذه الرساله .. مامعناها وماهي طريقه ازالتها لكي يعمل الملف جيدا

ربنا يحفظك ويبارك فيك استاذ ابراهيم الحداد

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

للرفع اريد من احد الاخوه المحترمين تجربه الملف على اكسيل 2010 اريد ان اعرف هل الملف عنده بيفتح عادي واللا فيه مشكله زي اللي في جهازي - الكمبيوتر-

للرفع اريد من احد الاخوه المحترمين تجربه الملف على اكسيل 2010 اريد ان اعرف هل الملف عنده بيفتح عادي واللا فيه مشكله زي اللي في جهازي - الكمبيوتر-

ربنا يبارك فيك استا ذ احمد وبعد استاذ وجيه ربنا يكرمك .. اريد منك تجربه الملف هل يعمل معك عادي ام يعطي رساله مفادها ان فيه ملفات مرجعيه ناقصه ؟

للرفع

ربنا يبارك فيك يا استاذ احمد على مشاركاتك الايجابيه وبعد لم تتم معي ولكني ارجو من احد الاخوه المحترمين ان يجرب فتح الملف على اكسيل 2010 ربما يكون المشكله من الجهاز ثانيا انا ارى الرساله الخطأ فيها انه يوجد ملفات مرجعيه ناقصه ولم استطع حل الرساله

===== ممكن كرما منك اخي الكريم استاذ احمد ان تعطيني رابط لبرنامج وينرار مفكوك حديث

يحفظكم الله ويرعاكم الملف عند فتحه يعطي رساله خطا رساله_خطا.bmp

للرفع

اخي الكريم استاذ احمد حفظك الله ورعاك اعتذر لتاخري عن الرد لظروف خارجه عن ارادتي ... نحمد الله ثانيا لم استطع تحميل الملف المرفق ولاادري ما السبب؟ ثالثا اعتقد ان الحل المرفق من طرفكم سيغير في عمل الكود وخاصه الخلايا التي تم تعطيلها

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

ربنا يحفظك ويصونك يارب استاذ احمد بدره جاري التجريب ماذا فعلت حتى اذا قابلتنا مثل هذه المشكله نجيد حلها ؟