علي المصري

السلام عليكم ورحمة الله وبركاته انا معك اخي ابو خليل في فصل البنين والبنات ولكن في مصر وخاصة في القرى يوجد الكثير من المدارس المشتركة بنين وبنات وخاصة في المناطق البعيدة وعلى فكرة التساؤل الاخير الذي سبب مشكلة ما هو إلا سؤال للنقاش من حيث البرمجة فقط وعلى هذا اسحب هذا التساؤل من النقاش لكن المهم ؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟ّ!!!!!!!!!!!!!! فين الكود المطلوب لعملية الترتيتب شكرا للجميع

السلام عليكم ورحمة الله وبركاته هل يوجد كود لترتيب درجات الطلاب على النحو التالي الأول ( الأولى للمؤنث ) الثاني ( الثانية للمؤنث ) وهكذا الترتيب يكون من الأكبر إلى الأصغر مع مراعات المذكر والمؤنث ==== وماذا يكون عليه الكود لو كانت المدرسة تحتوي على بنين وبنات ممكن الأول يكون ولد والثاني يكون بنت فيكون الترتيب الأول - الثانية ................ موضوع يريد المناقشة شكرا للجميع

تم تجميع الطرق الثلاثة معا ودا بعد اذن الاساتذة الكرام up_ChangeSubForm.rar

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

شكرا لك ابو آدم على هذا الطرح ولكني جديد في عالم البرمجه فقمت بعمل نموذج جديد في المرفق وجعلت قاعدة البيانات تبدأ به ارجو من حضراتكم كيف البرمجة في حالى أزرار التنقل وازرار الاختيار كما بالمرفق ارجو الشرح حتى اتمكن من عملها فيما بعد آسف على الازعاج شكرا NA_ChangeSubForm.rar

ممتاز هذا العمل لانه سيوفر الكثير من الوقت شكرا

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

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

شكرا الخطأ من عندي

شكرا اخي : محمد السوداني شكرا لجميع الاعضاء الذين يساهمون في هذا المنتدى ولا يبخلون بشيء عن باقي الاعضاء بالنسبة لتفقيط طرحت هذا الموضوع في الرابط التالي http://www.officena.net/ib/index.php?showtopic=42832&st=0&gopid=247254& وقد تم تعديل الوحدة النمطية واخر تعديل هو في المشاركة رقم 20 وذلك بفضل الله ثم الاعضاء الكرام ( ابوخليل و محمد السوداني ) شكر للجميع

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

ممتاز أبو خليل يا كنج انا عايز اعرف شيء هل غيرت في الكود شيء طلب اخير مرفق نموذج لقاعدة بيانات اقوم بالعمل عليها انظر إلى التفقيط باللغة الانجليزية تجد ان كلمة only مكررة مرتين فهل ممكن تعديلها شكرا Ali.rar

السلام عليكم ورحمة الله وبركاته نعم هي نفسها ولكن الفرق فيما يلي في مربع النص المراد اظهار التفقيط فيه حضراتكم كتبتم التالي =ArbNum2Text([dgre]) في الاكسيل كنت استخدم التالي في الخلية المراد إظهار التفقيط بها على فرض مثلا انها A1 =ArbNum2Text(A1; 2;3;"درجة";"درجات";1;"جزء";"أجزاء";1) فلاحظ اخي ان كلمة درجة موجودة في هذه الصيغة وليست في الوحدة النمطية فكيف يمكن ادراجها في الوحدة النمطية وهل يمكن استخدامها كما في اكسيل انا جربتها ولكن لم تفلح فما الحل

الاخوة ابو خليل و محمد السوداني جزاكم الله خيرا عما تقدموه من اسهامات اخي ابو خليل : ينقص هذا الكود إضافة كلمة درجة اخي محمد السوداني : لم اعرف كيف استخدم الكود شكرا

السلام عليكم ورحمة الله وبركاته اخواني الكرام الكود لا غبار عليه ولكن انظر اخي الكريم عندما تكون الدرجة 0 ماذا يكون التفقيط لو زاد العدد عن 399 انظر ما يكون التفقيط لان الكود مبني على الدرجات تكون اقل من 400 ولا بد ان تكون كلمة فقط في النهاية ودي سهل امرها فإذا تم تعديل الكود من ناحية الصفر والارقام الاكبر من 399 فيكون ممتاز أو إن احد من الاخوة تبنى الكود الذي وضعته في الموضوع وتحويله الى كود يستخدم في الاكسيس يكون ايضا ممتاز لانه يقوم بالتفقيط باللغتين شكرا اثقلت عليكم بالتساؤلات اعذروني وسامحوني

في منتدى الاكسيل وجدت الكود التالي للتفقيط وهو ممتاز بمعنى الكلمة يراعي القواعد للغة العربية وهذا الكود استخدمه منذ فترة على برنامج اكسيل الخاص بالدرجات منذ 3 سنوات والحين تذكرت هذا الكود '-- نسخة خاصة لأحد أعضاء منتدى أوفيسنا ، الرجاء عدم استخدامها من قبل الآخرين '-- 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 حيث يكتب في الخلية A1 أو اي خلية مراد التفقيط فيها ما يلي =ArbNum2Text(A9; 2;3;"درجة";"درجات";1;"جزء";"أجزاء";1) حاولت استخدامة مع الاكسيس بتغيير A1 الى sum لم يفلح ارجو منكم تعديله لكي يمكن استخدامه مع اكسيس شكرا للجميع

اخواني الكرام اخي احمد خلف ما زال الكود بحتاج للتعديل ليتماشى مع قواعد اللغة العربية مثال 4 = اربع درجات وليس اربعة درجات ( لان الاعداد من 3 إلى 9 تخالف المعدود من حيث الجنس ) 25 = خمس وعشرون درجة وليس خمسة وعشرون درجة او درجات وكلمة درجات لات تأتي إلا مع الارقام من 3 إلى 10 واسف يا اخواني ولكني احب اللغة العربية لغة القرآن الكريم مع اني مدرس رياضيات غفر الله لنا جميعا ولوالدينا وحفظ الله مصر شكرا لكم

أخي محمد السوداني شكرا لك على ثنائك ولكنني مبتدأ في الاكسيس والبرمجة فليس في مقدوري تصحيح أو تعديل في الاكواد إلا في بعض الحلات البسيطة شكرا لك اخي احمد خلف وعلى الكود وجاري التجربة

شكرا لك اخب وعلى الشرح بارك الله فيك

الكود التالي وجدته في احد المواقع وهو اتعطيل عمل shift , alt , ctrl فهل يمكن استخدامه بحيث يبدأ مع قاعدة البيانات ويستخدم في تعطيل ال shift فقط إليكم الكود Option Explicit Option Compare Text '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' modKeyState ' By Chip Pearson, www.cpearson.com, chip@cpearson.com ' This code is at www.cpearson.com/Excel/KeyTest.aspx ' This module contains functions for testing the state of the SHIFT, ALT, and CTRL ' keys. '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''''''''''''''' ' Declaration of GetKeyState API function. This ' tests the state of a specified key. '''''''''''''''''''''''''''''''''''''''''''''''''''' Private Declare Function GetKeyState Lib "user32" ( _ ByVal nVirtKey As Long) As Integer '''''''''''''''''''''''''''''''''''''''''' ' This constant is used in a bit-wise AND ' operation with the result of GetKeyState ' to determine if the specified key is ' down. '''''''''''''''''''''''''''''''''''''''''' Private Const KEY_MASK As Integer = &HFF80 ' decimal -128 ''''''''''''''''''''''''''''''''''''''''' ' KEY CONSTANTS. Values taken ' from VC++ 6.0 WinUser.h file. ''''''''''''''''''''''''''''''''''''''''' Private Const VK_LSHIFT = &HA0 Private Const VK_RSHIFT = &HA1 Private Const VK_LCONTROL = &HA2 Private Const VK_RCONTROL = &HA3 Private Const VK_LMENU = &HA4 Private Const VK_RMENU = &HA5 ''''''''''''''''''''''''''''''''''''''''' ' The following four constants simply ' provide other names, CTRL and ALT, ' for CONTROL and MENU. "CTRL" and ' "ALT" are more familiar than ' "CONTROL" and "MENU". These constants ' provide no additional functionality. ' They simply provide more familiar ' names. ''''''''''''''''''''''''''''''''''''''''' Private Const VK_LALT = VK_LMENU Private Const VK_RALT = VK_RMENU Private Const VK_LCTRL = VK_LCONTROL Private Const VK_RCTRL = VK_RCONTROL '''''''''''''''''''''''''''''''''''''''''''' ' The following constants are used to specify, ' when testing CTRL, ALT, or SHIFT, whether ' the Left key, the Right key, either the ' Left OR Right key, or BOTH the Left AND ' Right keys are down. ' ' By default, the key-test procedures make ' no distinction between the Left and Right ' keys and will return TRUE if either the ' Left or Right (or both) key is down. '''''''''''''''''''''''''''''''''''''''''''' Public Const BothLeftAndRightKeys = 0 Public Const LeftKey = 1 Public Const RightKey = 2 Public Const LeftKeyOrRightKey = 3 Public Function IsShiftKeyDown(Optional LeftOrRightKey As Long = LeftKeyOrRightKey) As Boolean '''''''''''''''''''''''''''''''''''''''''''''''' ' IsShiftKeyDown ' Returns TRUE or FALSE indicating whether the ' SHIFT key is down. ' ' If LeftOrRightKey is omitted or LeftKeyOrRightKey, ' the function return TRUE if either the left or the ' right SHIFT key is down. If LeftKeyOrRightKey is ' LeftKey, then only the Left SHIFT key is tested. ' If LeftKeyOrRightKey is RightKey, only the Right ' SHIFT key is tested. If LeftOrRightKey is ' BothLeftAndRightKeys, the codes tests whether ' both the Left and Right keys are down. The default ' is to test for either Left or Right, making no ' distiction between Left and Right. '''''''''''''''''''''''''''''''''''''''''''''''' Dim Res As Long Select Case LeftOrRightKey Case LeftKey Res = GetKeyState(VK_LSHIFT) And KEY_MASK Case RightKey Res = GetKeyState(VK_RSHIFT) And KEY_MASK Case BothLeftAndRightKeys Res = (GetKeyState(VK_LSHIFT) And GetKeyState(VK_RSHIFT) And KEY_MASK) Case Else Res = GetKeyState(vbKeyShift) And KEY_MASK End Select IsShiftKeyDown = CBool(Res) End Function Public Function IsControlKeyDown(Optional LeftOrRightKey As Long = LeftKeyOrRightKey) As Boolean '''''''''''''''''''''''''''''''''''''''''''''''' ' IsControlKeyDown ' Returns TRUE or FALSE indicating whether the ' CTRL key is down. ' ' If LeftOrRightKey is omitted or LeftKeyOrRightKey, ' the function return TRUE if either the left or the ' right CTRL key is down. If LeftKeyOrRightKey is ' LeftKey, then only the Left CTRL key is tested. ' If LeftKeyOrRightKey is RightKey, only the Right ' CTRL key is tested. If LeftOrRightKey is ' BothLeftAndRightKeys, the codes tests whether ' both the Left and Right keys are down. The default ' is to test for either Left or Right, making no ' distiction between Left and Right. '''''''''''''''''''''''''''''''''''''''''''''''' Dim Res As Long Select Case LeftOrRightKey Case LeftKey Res = GetKeyState(VK_LCTRL) And KEY_MASK Case RightKey Res = GetKeyState(VK_RCTRL) And KEY_MASK Case BothLeftAndRightKeys Res = (GetKeyState(VK_LCTRL) And GetKeyState(VK_RCTRL) And KEY_MASK) Case Else Res = GetKeyState(vbKeyControl) And KEY_MASK End Select IsControlKeyDown = CBool(Res) End Function Public Function IsAltKeyDown(Optional LeftOrRightKey As Long = LeftKeyOrRightKey) As Boolean '''''''''''''''''''''''''''''''''''''''''''''''' ' IsAltKeyDown ' Returns TRUE or FALSE indicating whether the ' ALT key is down. ' ' If LeftOrRightKey is omitted or LeftKeyOrRightKey, ' the function return TRUE if either the left or the ' right ALT key is down. If LeftKeyOrRightKey is ' LeftKey, then only the Left ALT key is tested. ' If LeftKeyOrRightKey is RightKey, only the Right ' ALT key is tested. If LeftOrRightKey is ' BothLeftAndRightKeys, the codes tests whether ' both the Left and Right keys are down. The default ' is to test for either Left or Right, making no ' distiction between Left and Right. '''''''''''''''''''''''''''''''''''''''''''''''' Dim Res As Long Select Case LeftOrRightKey Case LeftKey Res = GetKeyState(VK_LALT) And KEY_MASK Case RightKey Res = GetKeyState(VK_RALT) And KEY_MASK Case BothLeftAndRightKeys Res = (GetKeyState(VK_LALT) And GetKeyState(VK_RALT) And KEY_MASK) Case Else Res = GetKeyState(vbKeyMenu) And KEY_MASK End Select IsAltKeyDown = CBool(Res) End Function The following are test procedures to illustrate the code. Run the procedure named Test and then press the keys that you want to test. Test calls ProcTest via OnTime to allow you to press the appropriate keys. The results are displayed in the Debug window of the VBA Editor. Sub Test() ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' Test ' This is a procedure to test and demonstrate the Key-State ' functions above. Since you can't run a macro in the VBA ' Editor if the SHIFT, ALT, or CTRL key is down, this procedure ' uses OnTime to execute the ProcTest test procedure. OnTime ' will call ProcTest two seconds after running this Test ' procedure. Immediately after executing Test, press the ' key(s) (Left/Right SHIFT, ALT, or CTRL) you want to test ' for. The procedure called by OnTime, ProcTest, displays the ' status of the Left/Right SHIFT, ALT, and CTRL keys. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Application.OnTime Now + TimeSerial(0, 0, 2), "ProcTest", , True End Sub Sub ProcTest() ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' ProcTest ' This procedure simply displays the status of the Left adn Right ' SHIFT, ALT, and CTRL keys. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Debug.Print "SHIFT KEY: ", "LEFT: " & CStr(IsShiftKeyDown(LeftKey)), _ "RIGHT: " & CStr(IsShiftKeyDown(RightKey)), _ "EITHER: " & CStr(IsShiftKeyDown(LeftKeyOrRightKey)), _ "BOTH: " & CStr(IsShiftKeyDown(BothLeftAndRightKeys)) Debug.Print "ALT KEY: ", "LEFT: " & CStr(IsAltKeyDown(LeftKey)), _ "RIGHT: " & CStr(IsAltKeyDown(RightKey)), _ "EITHER: " & CStr(IsAltKeyDown(LeftKeyOrRightKey)), _ "BOTH: " & CStr(IsAltKeyDown(BothLeftAndRightKeys)) Debug.Print "CTRL KEY: ", "LEFT: " & CStr(IsControlKeyDown(LeftKey)), _ "RIGHT: " & CStr(IsControlKeyDown(RightKey)), _ "EITHER: " & CStr(IsControlKeyDown(LeftKeyOrRightKey)), _ "BOTH: " & CStr(IsControlKeyDown(BothLeftAndRightKeys)) End Sub

بالفعل جربت ذلك ولكن التفقيط به اخطاء عشرة درجة (خطأ ) المفروض عشر درجات فقط مائة وخمسون درجة فقط ونصف فقط ( خطأ ) المفروض مائة وخمسون درجة ونصف فقط شكرا على الاهتمام

شكرا لكل من ساهم في هذا الموضوع

اعمال مميزة شكرا لكم

سوف تجد كود التصدير إلى اكسيل في المشاركة رقم 6 بالموضوع التالي http://www.officena.net/ib/index.php?showtopic=42769