تفقيط باللغة العربية

[علي المصري]

السلام عليكم ورحمة الله وبركاته

اود معرفة كيفية استخدام كود التفقيط باللغة العربية لدرجات الطلاب

أرجو التوضيح بالشرح

كما ان هناك الكثير من أكواد ادراج صوره في نموذج ولكني استخدمت احدهم صلح مع اكسيس 2010 ولم يصلح مع 2003

فارجو من الاخوة وضع كود خاص بـ 2003 مع الشرح وآخر لاكسيس 2010 مع الشرح

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

[Bluemind]

اخوي بارك الله فيك

لو قمت بعمل بحث في المنتدى لوجدت عده حلول و اجابات من قبل

بالنسبه لموضوع التفقيط جرب الموضوع التالي

http://www.officena.net/ib/index.php?showtopic=40057&hl=%D8%AA%D9%81%D9%82%D9%8A%D8%B7

[علي المصري]

بالفعل جربت ذلك ولكن التفقيط به اخطاء

عشرة درجة (خطأ ) المفروض عشر درجات فقط

مائة وخمسون درجة فقط ونصف فقط ( خطأ ) المفروض مائة وخمسون درجة ونصف فقط

شكرا على الاهتمام

[محمد السوداني]

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

بخصوص ملاحظاتك أو أي ملاحظات أخرى من بقية الاخوة أقترح عليك التعديل لما تراه غير صحيح في الوحدة النمطية مع تقديرنا وإحترامنا الكبير لكاتبها والذي أعتقد انه قدم خدمة كبيرة للمستخدمين العرب والكمال لله وحده

مع ملاحظة حفظ نسخة منها قبل التعديل حتى يمكن الرجوع إليها عند حدوث خلل في التعديل الذي يحتاج لفهم أكوادها

وبهذه المناسبة أرجو من الأخوة عباقرة المنتدى تطويرها فهي تقبل حتى 12 منزلة فقط لتوسعتها وزيادة نطاقها لتصلح لحسابات الدول والجهات التي تتجاوز مئات المليارات

تم تعديل أغسطس 19, 2012 بواسطه محمد السوداني

[أحمد خلف]

السلام عليكم ورحمة الله وبركاته.

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

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

وبه تفقيط بالعربي واخر بالأنجليزي.

والله الموفق.

حل تفقيط الدرجات نهائى.rar

[علي المصري]

أخي محمد السوداني

شكرا لك على ثنائك

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

شكرا لك اخي احمد خلف وعلى الكود وجاري التجربة

[علي المصري]

اخواني الكرام

اخي احمد خلف

ما زال الكود بحتاج للتعديل ليتماشى مع قواعد اللغة العربية

مثال

4 = اربع درجات وليس اربعة درجات ( لان الاعداد من 3 إلى 9 تخالف المعدود من حيث الجنس )

25 = خمس وعشرون درجة وليس خمسة وعشرون درجة او درجات

وكلمة درجات لات تأتي إلا مع الارقام من 3 إلى 10

واسف يا اخواني

ولكني احب اللغة العربية لغة القرآن الكريم مع اني مدرس رياضيات

غفر الله لنا جميعا ولوالدينا وحفظ الله مصر

شكرا لكم

[علي المصري]

في منتدى الاكسيل وجدت الكود التالي للتفقيط وهو ممتاز بمعنى الكلمة يراعي القواعد للغة العربية

وهذا الكود استخدمه منذ فترة على برنامج اكسيل الخاص بالدرجات منذ 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 بواسطه علي المصري

[ابوخليل]

اليك وحدة نمطية وجدتها لك من اعداد البرمجي اللغو استاذنا محمد صالح أجزل الله له المثوبة

استللتها من اكسل واودعتها أكسس ، جرب ووافنا بالنتيجة

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

[محمد السوداني]

الأخ علي المصري جرب كود أستاذنا أبو خليل وأفيدنا وجميعنا إخوة وستجدنا عند حسن ظنك ان شاء الله

[علي المصري]

السلام عليكم ورحمة الله وبركاته

اخواني الكرام

الكود لا غبار عليه

ولكن

انظر اخي الكريم عندما تكون الدرجة 0 ماذا يكون التفقيط

لو زاد العدد عن 399 انظر ما يكون التفقيط

لان الكود مبني على الدرجات تكون اقل من 400

ولا بد ان تكون كلمة فقط في النهاية ودي سهل امرها

فإذا تم تعديل الكود من ناحية الصفر والارقام الاكبر من 399 فيكون ممتاز

أو إن احد من الاخوة تبنى الكود الذي وضعته في الموضوع وتحويله الى كود يستخدم في الاكسيس يكون ايضا ممتاز لانه يقوم بالتفقيط باللغتين

شكرا

اثقلت عليكم بالتساؤلات

اعذروني وسامحوني

[ابوخليل]

الصحيح ان الكود يكتب حتى 999

وزيادة الخير خير

هذا مثال يجمع الاثنين

تفقيط درجات.rar

[محمد السوداني]

الأخ علي واضح أن الأمر توقف عند اللغة وتحديداً الفرق بين المذكر والمؤنث وحسب معرفتي البسيطة بالحاسوب فانه من الصعب على الحاسوب تصنيف الاسماء المذكر من المؤنث والعربية تواجه دائما مشاكل مع الحاسوب ودورنا نحن ابناء العرب ان نساندها ونكمل النقص.

بالمراجعة لايوجد خطأ فالوحدة النمطية السابقة فهي معدة لتعمل مع الاسماء المذكرة مثل الريال وانت تحتاج لوحدة تعمل مع الاسماء المؤنثة لانك تحتاج لتفقيط الدرجات لأن الدرجة مؤنثة..

هدية لجميع الاخوة العرب وأعضاء المنتدى أضع الوحدة النمطية السابقة بعد أن قمت بتعديلها بنفسي لوحدة مذكرة لتعمل مع الاسماء المذكرة ووحدة مؤنثة لتعمل مع الاسماء المؤنثة والاثنان في نفس البرنامج ويتم استدعاء الوظيفة كالآتي:

الأسماء المذكرة نستدعي ModuleM عن طريق الوظيفة

NoToTxtM

الأسماء المؤنثة نستدعي ModuleF عن طريق الوظيفة

NoToTxtF

جرب وفي إنتظار رأيك لعمل أي تعديل لغوي يحفف الفائدة للجميع

Male and Female.zip

[علي المصري]

الاخوة ابو خليل و محمد السوداني

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

اخي ابو خليل : ينقص هذا الكود إضافة كلمة درجة

اخي محمد السوداني : لم اعرف كيف استخدم الكود

شكرا

[ابوخليل]

أو إن احد من الاخوة تبنى الكود الذي وضعته في الموضوع وتحويله الى كود يستخدم في الاكسيس يكون ايضا ممتاز لانه يقوم بالتفقيط باللغتين

هذا الذي عملته لك في المثال السابق

بالعربية ، ويمكنك تجربة اللغة الاخرى

[محمد السوداني]

الاخوة ابو خليل و محمد السوداني

اخي محمد السوداني : لم اعرف كيف استخدم الكود

شكرا

هو نفس الوحدة النمطية التي كنت تشكو من عدم دقتها اللغوية تم تعديل الفاظها فكيف كنت تستخدم تلك ؟؟

[علي المصري]

السلام عليكم ورحمة الله وبركاته

نعم هي نفسها ولكن الفرق فيما يلي

في مربع النص المراد اظهار التفقيط فيه حضراتكم كتبتم التالي

=ArbNum2Text([dgre])

في الاكسيل كنت استخدم التالي في الخلية المراد إظهار التفقيط بها على فرض مثلا انها A1

=ArbNum2Text(A1; 2;3;"درجة";"درجات";1;"جزء";"أجزاء";1)

فلاحظ اخي

ان كلمة درجة موجودة في هذه الصيغة وليست في الوحدة النمطية

فكيف يمكن ادراجها في الوحدة النمطية

وهل يمكن استخدامها كما في اكسيل

انا جربتها ولكن لم تفلح

فما الحل

تم تعديل أغسطس 24, 2012 بواسطه علي المصري

[ابوخليل]

انا جربتها ولكن لم تفلح

فما الحل

هل انت متأكد ؟

انظر المثال بعد التعديل

تفقيط درجات.rar

[علي المصري]

ممتاز أبو خليل يا كنج

انا عايز اعرف شيء

هل غيرت في الكود شيء

طلب اخير

مرفق نموذج لقاعدة بيانات اقوم بالعمل عليها

انظر إلى التفقيط باللغة الانجليزية

تجد ان كلمة only مكررة مرتين

فهل ممكن تعديلها

شكرا

Ali.rar

[ابوخليل]

انا عايز اعرف شيء

هل غيرت في الكود شيء

ابدا

تم التعديل

Ali2.rar

[علي المصري]

السلام عليكم ورحمة الله وبركاته

شكرا على التعديل وجزاك الله خيرا

ولكن اخي

ما فائدة الوحدة النمطية AbuHamoud3

التي اضفتها لقاعدة البيانات

ارجو الشرح

[ابوخليل]

لم اضف شيئا

انظر الى مثالك قبل التعديل

[علي المصري]

شكرا

الخطأ من عندي

[N_ELMASRY]

جزاكم الله خيرًا على المجهود الرائع

[N_ELMASRY]

جزاكم الله خيرًا على المجهود الممتاز ...... وجعله الله فى ميزان حسناتكم