علي المصري قام بنشر أغسطس 12, 2012 قام بنشر أغسطس 12, 2012 السلام عليكم ورحمة الله وبركاته اود معرفة كيفية استخدام كود التفقيط باللغة العربية لدرجات الطلاب أرجو التوضيح بالشرح كما ان هناك الكثير من أكواد ادراج صوره في نموذج ولكني استخدمت احدهم صلح مع اكسيس 2010 ولم يصلح مع 2003 فارجو من الاخوة وضع كود خاص بـ 2003 مع الشرح وآخر لاكسيس 2010 مع الشرح وكل عام انتم بخير
Bluemind قام بنشر أغسطس 18, 2012 قام بنشر أغسطس 18, 2012 اخوي بارك الله فيك لو قمت بعمل بحث في المنتدى لوجدت عده حلول و اجابات من قبل بالنسبه لموضوع التفقيط جرب الموضوع التالي http://www.officena.net/ib/index.php?showtopic=40057&hl=%D8%AA%D9%81%D9%82%D9%8A%D8%B7
علي المصري قام بنشر أغسطس 19, 2012 الكاتب قام بنشر أغسطس 19, 2012 بالفعل جربت ذلك ولكن التفقيط به اخطاء عشرة درجة (خطأ ) المفروض عشر درجات فقط مائة وخمسون درجة فقط ونصف فقط ( خطأ ) المفروض مائة وخمسون درجة ونصف فقط شكرا على الاهتمام
محمد السوداني قام بنشر أغسطس 19, 2012 قام بنشر أغسطس 19, 2012 (معدل) الاخ علي كل عام وانتم بخير و ماشاء الله عليك لا تسير بسرعة فقط ولكنك تقفز قفزا وتثير موضوعات مهمة ومفيدة للجميع بخصوص ملاحظاتك أو أي ملاحظات أخرى من بقية الاخوة أقترح عليك التعديل لما تراه غير صحيح في الوحدة النمطية مع تقديرنا وإحترامنا الكبير لكاتبها والذي أعتقد انه قدم خدمة كبيرة للمستخدمين العرب والكمال لله وحده مع ملاحظة حفظ نسخة منها قبل التعديل حتى يمكن الرجوع إليها عند حدوث خلل في التعديل الذي يحتاج لفهم أكوادها وبهذه المناسبة أرجو من الأخوة عباقرة المنتدى تطويرها فهي تقبل حتى 12 منزلة فقط لتوسعتها وزيادة نطاقها لتصلح لحسابات الدول والجهات التي تتجاوز مئات المليارات تم تعديل أغسطس 19, 2012 بواسطه محمد السوداني
أحمد خلف قام بنشر أغسطس 19, 2012 قام بنشر أغسطس 19, 2012 السلام عليكم ورحمة الله وبركاته. كل عام وانتم بخير. تفضل اخي علي هذا نموذج للتفقيط للعملات وقد قمت بتعديله حتي يتساير مع تفقيط الدرجات وبه تفقيط بالعربي واخر بالأنجليزي. والله الموفق. حل تفقيط الدرجات نهائى.rar 1
علي المصري قام بنشر أغسطس 22, 2012 الكاتب قام بنشر أغسطس 22, 2012 أخي محمد السوداني شكرا لك على ثنائك ولكنني مبتدأ في الاكسيس والبرمجة فليس في مقدوري تصحيح أو تعديل في الاكواد إلا في بعض الحلات البسيطة شكرا لك اخي احمد خلف وعلى الكود وجاري التجربة
علي المصري قام بنشر أغسطس 22, 2012 الكاتب قام بنشر أغسطس 22, 2012 اخواني الكرام اخي احمد خلف ما زال الكود بحتاج للتعديل ليتماشى مع قواعد اللغة العربية مثال 4 = اربع درجات وليس اربعة درجات ( لان الاعداد من 3 إلى 9 تخالف المعدود من حيث الجنس ) 25 = خمس وعشرون درجة وليس خمسة وعشرون درجة او درجات وكلمة درجات لات تأتي إلا مع الارقام من 3 إلى 10 واسف يا اخواني ولكني احب اللغة العربية لغة القرآن الكريم مع اني مدرس رياضيات غفر الله لنا جميعا ولوالدينا وحفظ الله مصر شكرا لكم 1
علي المصري قام بنشر أغسطس 22, 2012 الكاتب قام بنشر أغسطس 22, 2012 (معدل) في منتدى الاكسيل وجدت الكود التالي للتفقيط وهو ممتاز بمعنى الكلمة يراعي القواعد للغة العربية وهذا الكود استخدمه منذ فترة على برنامج اكسيل الخاص بالدرجات منذ 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 لم يفلح ارجو منكم تعديله لكي يمكن استخدامه مع اكسيس شكرا للجميع تم تعديل أغسطس 22, 2012 بواسطه علي المصري
ابوخليل قام بنشر أغسطس 22, 2012 قام بنشر أغسطس 22, 2012 اليك وحدة نمطية وجدتها لك من اعداد البرمجي اللغو استاذنا محمد صالح أجزل الله له المثوبة استللتها من اكسل واودعتها أكسس ، جرب ووافنا بالنتيجة Function n2t(d As Double) As String m = Int(d / 100) h = Int(d / 10) - (m * 10) a = Int(d - (m * 100 + h * 10)) k = d - (m * 100 + h * 10 + a) n2t = num((m), 3) & IIf(m > 0 And (a > 0 Or h > 0), " و ", "") & num((a), 1) & IIf(a > 0 And h > 1, " و ", " ") & num((h), 2) n2t = Replace(n2t, "اثنتانِ عشرة", "اثنتا عشرة") n2t = Replace(n2t, "ثمانمائة", "ثمنمائة") n2t = Replace(n2t, "ثلاثمائة", "ثلثمائة") n2t = Replace(n2t, "و عشرة", "و عشر") n2t = IIf(n2t = " عشرة", "عشر", n2t) n2t = IIf(n2t = "مائتانِ ", "مائتا", n2t) n2t = "فقط " & n2t & IIf(h = 0 And a = 2, "درجتانِ", IIf((h = 1 And a = 0) Or ((h = 0 And a > 2)), " درجاتٍ", IIf(h = 0 And a = 0, " درجةٍ", " درجةً"))) & IIf(k > 0, " و نصفٌ", "") n2t = Replace(n2t, " ", " ") n2t = Replace(n2t, "إحدى درجةً", "درجةٌ") n2t = Replace(n2t, "اثنتانِ درجتانِ", "درجتانِ") End Function Function num(n As Integer, t As Integer) As String m = "مائة" h = "ونَ" Select Case n Case Is = 1 num = IIf(t = 3, m, IIf(t = 2, "عشرة", "إحدى")) Case Is = 2 num = IIf(t = 3, "مائتانِ", IIf(t = 2, "عشرونَ", "اثنتانِ")) Case Is >= 3 num = IIf(t = 3, nn(n) & m, IIf(t = 2, nn(n) & h, nn(n))) End Select End Function Function nn(n As Integer) As String Select Case n Case Is = 3 nn = "ثلاث" Case Is = 4 nn = "أربع" Case Is = 5 nn = "خمس" Case Is = 6 nn = "ست" Case Is = 7 nn = "سبع" Case Is = 8 nn = "ثمان" Case Is = 9 nn = "تسع" End Select End Function تفقيط درجات.rar
محمد السوداني قام بنشر أغسطس 23, 2012 قام بنشر أغسطس 23, 2012 الأخ علي المصري جرب كود أستاذنا أبو خليل وأفيدنا وجميعنا إخوة وستجدنا عند حسن ظنك ان شاء الله
علي المصري قام بنشر أغسطس 23, 2012 الكاتب قام بنشر أغسطس 23, 2012 السلام عليكم ورحمة الله وبركاته اخواني الكرام الكود لا غبار عليه ولكن انظر اخي الكريم عندما تكون الدرجة 0 ماذا يكون التفقيط لو زاد العدد عن 399 انظر ما يكون التفقيط لان الكود مبني على الدرجات تكون اقل من 400 ولا بد ان تكون كلمة فقط في النهاية ودي سهل امرها فإذا تم تعديل الكود من ناحية الصفر والارقام الاكبر من 399 فيكون ممتاز أو إن احد من الاخوة تبنى الكود الذي وضعته في الموضوع وتحويله الى كود يستخدم في الاكسيس يكون ايضا ممتاز لانه يقوم بالتفقيط باللغتين شكرا اثقلت عليكم بالتساؤلات اعذروني وسامحوني
ابوخليل قام بنشر أغسطس 23, 2012 قام بنشر أغسطس 23, 2012 الصحيح ان الكود يكتب حتى 999 وزيادة الخير خير هذا مثال يجمع الاثنين تفقيط درجات.rar
محمد السوداني قام بنشر أغسطس 23, 2012 قام بنشر أغسطس 23, 2012 الأخ علي واضح أن الأمر توقف عند اللغة وتحديداً الفرق بين المذكر والمؤنث وحسب معرفتي البسيطة بالحاسوب فانه من الصعب على الحاسوب تصنيف الاسماء المذكر من المؤنث والعربية تواجه دائما مشاكل مع الحاسوب ودورنا نحن ابناء العرب ان نساندها ونكمل النقص. بالمراجعة لايوجد خطأ فالوحدة النمطية السابقة فهي معدة لتعمل مع الاسماء المذكرة مثل الريال وانت تحتاج لوحدة تعمل مع الاسماء المؤنثة لانك تحتاج لتفقيط الدرجات لأن الدرجة مؤنثة.. هدية لجميع الاخوة العرب وأعضاء المنتدى أضع الوحدة النمطية السابقة بعد أن قمت بتعديلها بنفسي لوحدة مذكرة لتعمل مع الاسماء المذكرة ووحدة مؤنثة لتعمل مع الاسماء المؤنثة والاثنان في نفس البرنامج ويتم استدعاء الوظيفة كالآتي: الأسماء المذكرة نستدعي ModuleM عن طريق الوظيفة NoToTxtM الأسماء المؤنثة نستدعي ModuleF عن طريق الوظيفة NoToTxtF جرب وفي إنتظار رأيك لعمل أي تعديل لغوي يحفف الفائدة للجميع Male and Female.zip 1
علي المصري قام بنشر أغسطس 23, 2012 الكاتب قام بنشر أغسطس 23, 2012 الاخوة ابو خليل و محمد السوداني جزاكم الله خيرا عما تقدموه من اسهامات اخي ابو خليل : ينقص هذا الكود إضافة كلمة درجة اخي محمد السوداني : لم اعرف كيف استخدم الكود شكرا
ابوخليل قام بنشر أغسطس 23, 2012 قام بنشر أغسطس 23, 2012 أو إن احد من الاخوة تبنى الكود الذي وضعته في الموضوع وتحويله الى كود يستخدم في الاكسيس يكون ايضا ممتاز لانه يقوم بالتفقيط باللغتين هذا الذي عملته لك في المثال السابق بالعربية ، ويمكنك تجربة اللغة الاخرى
محمد السوداني قام بنشر أغسطس 23, 2012 قام بنشر أغسطس 23, 2012 الاخوة ابو خليل و محمد السوداني اخي محمد السوداني : لم اعرف كيف استخدم الكود شكرا هو نفس الوحدة النمطية التي كنت تشكو من عدم دقتها اللغوية تم تعديل الفاظها فكيف كنت تستخدم تلك ؟؟
علي المصري قام بنشر أغسطس 24, 2012 الكاتب قام بنشر أغسطس 24, 2012 (معدل) السلام عليكم ورحمة الله وبركاته نعم هي نفسها ولكن الفرق فيما يلي في مربع النص المراد اظهار التفقيط فيه حضراتكم كتبتم التالي =ArbNum2Text([dgre]) في الاكسيل كنت استخدم التالي في الخلية المراد إظهار التفقيط بها على فرض مثلا انها A1 =ArbNum2Text(A1; 2;3;"درجة";"درجات";1;"جزء";"أجزاء";1) فلاحظ اخي ان كلمة درجة موجودة في هذه الصيغة وليست في الوحدة النمطية فكيف يمكن ادراجها في الوحدة النمطية وهل يمكن استخدامها كما في اكسيل انا جربتها ولكن لم تفلح فما الحل تم تعديل أغسطس 24, 2012 بواسطه علي المصري
ابوخليل قام بنشر أغسطس 24, 2012 قام بنشر أغسطس 24, 2012 انا جربتها ولكن لم تفلح فما الحل هل انت متأكد ؟ انظر المثال بعد التعديل تفقيط درجات.rar
علي المصري قام بنشر أغسطس 24, 2012 الكاتب قام بنشر أغسطس 24, 2012 ممتاز أبو خليل يا كنج انا عايز اعرف شيء هل غيرت في الكود شيء طلب اخير مرفق نموذج لقاعدة بيانات اقوم بالعمل عليها انظر إلى التفقيط باللغة الانجليزية تجد ان كلمة only مكررة مرتين فهل ممكن تعديلها شكرا Ali.rar
ابوخليل قام بنشر أغسطس 24, 2012 قام بنشر أغسطس 24, 2012 انا عايز اعرف شيء هل غيرت في الكود شيء ابدا تم التعديل Ali2.rar
علي المصري قام بنشر أغسطس 24, 2012 الكاتب قام بنشر أغسطس 24, 2012 السلام عليكم ورحمة الله وبركاته شكرا على التعديل وجزاك الله خيرا ولكن اخي ما فائدة الوحدة النمطية AbuHamoud3 التي اضفتها لقاعدة البيانات ارجو الشرح
N_ELMASRY قام بنشر مايو 5, 2015 قام بنشر مايو 5, 2015 جزاكم الله خيرًا على المجهود الممتاز ...... وجعله الله فى ميزان حسناتكم
الردود الموصى بها
Join the conversation
You can post now and register later. If you have an account, sign in now to post with your account.