إنتقال للمحتوى

ابحث فى الموقع مع جوجل

بحث مخصص

تأكد من صحة الحديث قبل نشره



بحث عن:

جديــــــد New

شبكة محترفى أوراكل

<




صورة

شرح عمل شيت كنترول ( درة أعمال العلامة عبد الله باقشير)

لجمبع المدارس

  • من فضلك قم بتسجيل الدخول للرد
78 رد (ردود) على هذا الموضوع

#1 محمدي عبد السميع

محمدي عبد السميع
  • Pmembers-2
  • 594 مشاركة
  • Gender:Male

تاريخ المشاركة 21 April 2012 - 05:09 AM

بسم الله الرحمن الرحيم

الحمد لله و الشكر له اذي أنعم علينا بنعم لاتعد و لاتحصى

ومن هذه النعم وجود هذا المنتدى القيم

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

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

وهو من أحب الناس إلى قلب اخيه الأستاذ / محمدي عبد السميع عبد الغني

حفظه الله ورعاه وحفظ الجميع من كل سوء ......... آمين يارب العالمين

وبعد :


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



بسم الله نبدأ

أولا : عند تصميم أي برنامج لأعمال الكنترول نحتاج الى صفحة بيانات أساسية وفي هذه الصفحة نحتاج الى
*** حساب العمر عند يوم واحد أكوبر من العام الدراسي القادم
وتوجد معادلات كثيرة لكن أفضلها وأسهلها على الإطلاق هذه المعادلات
=IF($E7<>"";DATEDIF($E7;$J$5;"Y");"")   لحساب عدد السنوات
=IF($E7<>"";DATEDIF($E7;$J$5;"Ym");"")   لحساب عدد الشهور
=IF($E7<>"";DATEDIF($E7;$J$5;"MD");"")  لحساب عدد الأيام

أما إذا كنت من هواة الأكواد فهذا الكود
للبطل الهمام بضم الهاء وفتح الميم الأولى عبد الله ياقشير
'============================================"
'   دالة حساب العمر بالتقويم الميلادي
تاريخ الميلاد  Mydate_Birth
التاريخ الذي تريد حساب العمر عنده Mydate
اذا كان فارغا سيتم احتساب اليوم
'============================================"
Function kh_count_y_m_d(Mydate_Birth As Date, Optional Mydate_Now, Optional Y_M_D As String = "Y_M_D")
Dim MyDate As Date
Dim D_1 As Integer, D_2 As Integer, M_1 As Integer, M_2 As Integer, Y_1 As Integer _
, Y_2 As Integer, d As Integer, M As Integer, Y As Integer
If IsDate(Mydate_Now) Then MyDate = Mydate_Now Else MyDate = Date
If IsDate(Mydate_Birth) And CDate(Mydate_Birth) <= CDate(MyDate) Then
	D_1 = Day(MyDate): D_2 = Day(Mydate_Birth)
	M_1 = Month(MyDate): M_2 = Month(Mydate_Birth)
	Y_1 = Year(MyDate): Y_2 = Year(Mydate_Birth)
	If D_1 >= D_2 Then d = D_1 - D_2: M = 0 Else d = D_1 + 30 - D_2: M = -1
	If M_1 + M >= M_2 Then M = M_1 + M - M_2: Y = 0 Else M = M_1 + M + 12 - M_2: Y = -1
	Y = Y_1 + Y - Y_2
	If Y_M_D = "Y_M_D" Then kh_count_y_m_d = d & "d-" & M & "m-" & Y & "y"
	If Y_M_D = "Y" Then kh_count_y_m_d = Y
	If Y_M_D = "M" Then kh_count_y_m_d = M
	If Y_M_D = "D" Then kh_count_y_m_d = d
End If
End Function


*** ونحتاج أيضا الخلية النشطة : وهي آخر حلية مكتوب فيها في آخر صف و تسهل لنا الوصول الى الصف الأخير الفارغ لإضافة بيانات أخرى إذا أردنا
Sub nasheta()
Dim U As Integer
U = ActiveCell.Row
Dim LastRow As Integer
LastRow = Cells(Rows.Count, "B").End(xlUp).Row + 1
If U = LastRow Then
Range("B7").Select
Else
Range("B" & LastRow).Select
End If
ActiveWindow.View = xlNormalView
End Sub

ماعليك إلا أن تربط زر بهذا الكود وهذه هي









طريقة ربط زر بكود


اختر أي زر يعجبك منظره ثم اضغط عليه بيمين الماوس
واختر نسخ ( copy)
ثم حدد المكان الذي تريد اللصق فيه أو إنشاء الزر فيه
واضغط بيمين الماوس واختر لصق ( past )
حرك الماوس في اتجاه الإطار الموجود حول الزر الذي لصقته ستظهر علامة الزائد و في كل اتجاه من علامة الزائد يوجد ايضا علامة زائد أخرى
ثم اضغط بيمين الماوس واختر تعيين ماكر
و ستطهر اسماء الماكروهات اختر الماكرو المطلوب ثم أوكي








طريقة تحريك زر


ملحوظه عند وجود علامة الزائد و في كل اتجاه منها يوجد ايضا علامة الزائد يمكنك الضغط بيسار الماوس وأنت مستمر بالضغط حركها إلى أي مكان








جرب عمل ذلك واحمد الله


*** سنجتاج أيضا الى كود يخفي عدد من الأسطر حتى نجصل عل أكبر مساحة ممكنه من الصفحة للرؤية و الكتابه بها
وهذا هو الكود الخاص بذلك " كود الاخفاء"
Sub kh_Hidden()
With Range("A2:A5")
	If .EntireRow.Hidden Then
		.EntireRow.Hidden = False
	Else
		.EntireRow.Hidden = True
	End If
End With
End Sub

*** سنجتاج أيضا إلى




كود لعمل المسلسل أوتوماتيكي


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




كود لترتيب الطلاب حسب النوع أولا

ثم ترتيب الطلاب تصاعديا بدون زر


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




" كود التسلسل الاوتوماتيكي والترتيب الهجائي"


Private Sub Worksheet_Activate()
Set WW = Application.WorksheetFunction
SS = WW.CountA(Range("B7:B1000")) + 6
EE = WW.CountA(Range("C7:C1000")) + 6
Application.ScreenUpdating = False
Range("B7:Z1000").Sort [c7], xlAscending
Range("B7:Z1000").Sort [D7], xlDescending
For U = 7 To EE
	Cells(U, 4).NumberFormat = "yyyy/mm/dd"
Next
Range("B7:B1000").ClearContents
[B7] = 1
[B8] = 2
Range("B7:B8").Select
On Error Resume Next
Selection.AutoFill Destination:=Range("B7:B" & EE)
Application.GoTo [B7]
'Application.ScreenUpdating = True
End Sub

ملفات مرفقة



#2 محمدي عبد السميع

محمدي عبد السميع
  • Pmembers-2
  • 594 مشاركة
  • Gender:Male

تاريخ المشاركة 21 April 2012 - 05:25 AM

يتبقى لنا في الصفحة الاساسية بضع معادلات لتضبط عملية ادخال البيانات بدقة
=SUMPRODUCT(--(INDEX(البيانات;0;3)="ولد");--(INDEX(البيانات;0;8)="مسلم"))
وهذه المعادلة تعني عدد الاولاد المسلمين
=SUMPRODUCT(--(INDEX(البيانات;0;3)="بنت");--(INDEX(البيانات;0;8)="مسلمة"))
وهذه المعادلة تعني عدد البنات المسلمات
وهذه المعادلات ستفيد في دقة الاعداد المدخلة ونوعيتها
فإذا تمت المدخلات صحيحة ستجد على الفور كلمة أحسنت

#3 محمدي عبد السميع

محمدي عبد السميع
  • Pmembers-2
  • 594 مشاركة
  • Gender:Male

تاريخ المشاركة 21 April 2012 - 05:48 AM

وهذه ضفحة بيانات أساسية

ملفات مرفقة



#4 محمدي عبد السميع

محمدي عبد السميع
  • Pmembers-2
  • 594 مشاركة
  • Gender:Male

تاريخ المشاركة 21 April 2012 - 06:51 AM

هنا سنرفق كود لعمل اللجان ولا أروع منه فهو مرن ويستطيع عمل اللجان لكافة المدارس بإذن الله وبكافة المخرجات
بارك الله في العلامة عبد الله باقشير
ونحن - ( الأستاذ محمدي عبد السميع ) - والجميع معه

وللحديث بقية

ملفات مرفقة



#5 كعبلاوى

كعبلاوى
  • Members-1
  • 85 مشاركة

تاريخ المشاركة 21 April 2012 - 08:38 AM

بارك الله فيك يا أستاذ محمدى و بارك الله في العلامة عبد الله باقشير وأكثر من أمثالكم لخدمة أعضاء المنتدى



#6 عبدالله المجرب

عبدالله المجرب

    مراقب عام

  • مراقب عام
  • 5110 مشاركة
  • Gender:Male
  • Location:مملكة البحرين
  • Interests:صرح اوفسينا التعليمي

تاريخ المشاركة 21 April 2012 - 10:11 AM

اخي محمدي
تم افتتاح مكتبة الاكواد وهذا رابطه
http://www.officena....oads&showcat=16
لما لا تستغله في هذه السلسلة التعليمية حتي يسهل الرجوع اليه
والامر متروك لك
  • أباالحسن معجب بهذا

أخــ أبو احمد ــوكم


1
news.gif
 

حسابي في الفيسبوك

حسابي في تويتــــر

 

اعذروني ففي الفترة القادمة سيكون تواجدي في المنتدى ضيق جداً وذلك للانشغال في دورة لمدة 6 شهور بعد الدوام

 


#7 حسين شاكر

حسين شاكر
  • Members-2
  • 261 مشاركة
  • Gender:Male

تاريخ المشاركة 21 April 2012 - 12:27 PM

اكرمك الله اخى محمدى انطلق للامام رائع جدا

#8 محمدي عبد السميع

محمدي عبد السميع
  • Pmembers-2
  • 594 مشاركة
  • Gender:Male

تاريخ المشاركة 22 April 2012 - 08:37 AM

شكرا لمروركم الكريم وبعد

الاخ عبد الله

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

انقل ما تشاء من الاكواد

وأحب أن أوضح ان الأكواد خاصة بالعالم العلامة عبد الله باقشير

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

وانتظروا بمشيئة الله تكملة

برنامج درة أعمال الكنترول



#9 محمدي عبد السميع

محمدي عبد السميع
  • Pmembers-2
  • 594 مشاركة
  • Gender:Male

تاريخ المشاركة 23 April 2012 - 12:12 AM

كودان احدهما لاخفاء الأعمده المختارة

والآخر لاخفاء أشرطة القوائم


الاستاذ الفاضل عبد الله

كيف اضيف الأكواد الى الرابط مكتبة الأكواد ؟

ملفات مرفقة



#10 محمدي عبد السميع

محمدي عبد السميع
  • Pmembers-2
  • 594 مشاركة
  • Gender:Male

تاريخ المشاركة 24 April 2012 - 08:35 AM

كود للفرز

هذه الأكواد هي روائع الأعمال التي تخص رجال التربية والتعليم

وكثير غيرهم


سيتم اضافة كود لعمل أرقام الجلوس

مع الكود الاسبق الخاص بعمل اللجان

ان شاء الله في أقرب وقت ممكن

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

ملفات مرفقة

  • ملف مرفق  فرز.rar   10.13كيلو   596 عدد مرات التحميل


#11 محمدي عبد السميع

محمدي عبد السميع
  • Pmembers-2
  • 594 مشاركة
  • Gender:Male

تاريخ المشاركة 25 April 2012 - 08:51 AM

كودان مهمان

أحدهما لدقة الفرز وازالة المسافات في عمود الأسماء ماعدا المسافات المفردة

وكود آخر لخروج الملف واغلاقه



بارك الله لنا ولكم

آمين

ملفات مرفقة



#12 جلال هشام

جلال هشام
  • Members-1
  • 2 مشاركة

تاريخ المشاركة 25 April 2012 - 10:55 AM

Thank for every thing

#13 محمدي عبد السميع

محمدي عبد السميع
  • Pmembers-2
  • 594 مشاركة
  • Gender:Male

تاريخ المشاركة 26 April 2012 - 11:37 PM

كودان احدهما لمعاينة الطباعه

والآخر لمعاينة الطباعة مع امكانية الطباعه

بارك الله لنا ولكم

آمين

ملفات مرفقة



#14 عبدالله باقشير

عبدالله باقشير

    مدير قسم الإكسيل

  • مراقب عام
  • 5059 مشاركة
  • Gender:Male
  • Location:اليمن

تاريخ المشاركة 27 April 2012 - 04:27 AM

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

ودمتم في حفظ الله

p54.gif




p65.gif



p0.gif




p5.gif


#15 محمدي عبد السميع

محمدي عبد السميع
  • Pmembers-2
  • 594 مشاركة
  • Gender:Male

تاريخ المشاركة 28 April 2012 - 01:53 AM

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

اخي المحترم العالم العلامة عبد الله باقشير

جعل الله هذا العمل في ميزان حسناتك وحسناتنا

آمين يارب العالمين


  • خالد ابو حمزة معجب بهذا

#16 محمدي عبد السميع

محمدي عبد السميع
  • Pmembers-2
  • 594 مشاركة
  • Gender:Male

تاريخ المشاركة 28 April 2012 - 02:11 AM

أكواد أحدهم لحساب العمر بالتاريخ الميلادي

والثاني لحساب العمر بالتاريخ الهجري

والثالث واجهه متميزة للمحترم عماد الحسامي

*********

وأنا سائل أخاً إنتفع بشيء من الموضوع
أن يدعو لي ولوالدي ، ومشايخي ، وسائر أحبابنا ، أجمعين،وكل من ساهم بكود او عمل ينتفع به
ولاننسى الدعاء للحبيب الغالي الذي أفاض عليا بكرم زائد وهو العالم العلامة والبحر الفهامه / عبد الله باقشير
وعلى الله الكريم اعتمادي ، وإليه تفويضي واستنادي، وحسببي الله ونعم الوكيل، ولا حول ولا قوة إلا بالله العزيز الحكيم

ملفات مرفقة



#17 محمدي عبد السميع

محمدي عبد السميع
  • Pmembers-2
  • 594 مشاركة
  • Gender:Male

تاريخ المشاركة 29 April 2012 - 06:30 PM

كود للتنقل بين الصفحات مهما تغيرت اسماؤها

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

[center]
[/color][/size][/center]

[size=6][color=#0000CD]    ' ' åÐÇ ÇáßæÏ ááÚÇáã ÇáÚáÇãÉ ÛÈÏ Çááå ÈÇÞÓíÑ
    [/color][/size]
[size=6][color=#0000CD]Sub GO_TO()
On Error Resume Next
  Application.CommandBars("Workbook Tabs").Controls("More Sheets...").Execute
  If Err.Number > 0 Then
    Err.Clear
    Application.CommandBars("Workbook Tabs").ShowPopup
  End If
  ActiveWindow.ScrollColumn = 1
  ActiveWindow.ScrollRow = 1
  On Error GoTo 0
End Sub

لاادري لماذا تظهر اللغة العربية بهذه الصورة

ملفات مرفقة



#18 محمدي عبد السميع

محمدي عبد السميع
  • Pmembers-2
  • 594 مشاركة
  • Gender:Male

تاريخ المشاركة 30 April 2012 - 09:43 PM

كود تفقيط ولاأروع

يصلح لتحويل ارقام المجموع الكلي للطلاب الى تفقيط

ويصلح ايضا لرجال الماهيات



'-- Abo Hadi, 28/07/2003 --'
'-- Last update on 28/07/2006
' تم إضافة تشكيل بعض التفقيط الذي يسمح بالتشكيل الثابت
'وتم اضافة الحروف (ء و اء و أ) إلى الحروف التي لا يأتي بعدها ألف التنوين المنصوب
' وتم إضافة كلمة (فقط لا غير ) في آخر التفقيط
'وذلك في 9/8/2007 (يوم ميلادي) محمد صالح
Option Explicit
Public Const vArabic As Byte = 1
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 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 7) As Long
  Dim Result1(0 To 8) As String
  Dim Parts_(0 To 13) 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) = "ترليوناتٍ"
  Parts_(12) = "كدرليوناتٍ"
  Parts_(13) = "كوينتليوناتٍ"
  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 <> "" And InStr(2, Plural, Sngl_2) > 0 Then
	Sngl_2 = ""
  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) + 7)
			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
	'{------------------------------------------}
	For K = 0 To Parts - 1
	  Only_ = AddAnd(Only_, Result1(K), "", And_, Lang)
	Next K
	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 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_ = CStr(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
  If Dec > 6 Then Dec = 6
  Num_ = Format(InNum, "0" & IIf(Dec > 0, ".", "") & String(Dec, "0"))
  If Dec > 0 Then FracS = "0." & Right(Num_, Dec) Else FracS = ""
  If Dec > 0 Then Num_ = Left(Num_, Len(Num_) - Dec - 1)
  FracVal = Val(FracS)
  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")))
	End Select
	  Case 3
		Select Case Lang
		  Case vArabic:  FracS = CLng(FracNum) & " " & IIf(FracNum >= 3 And FracNum <= 10, PFrac, SFrac)
				  End Select
	  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)
				  End Select
	End Select
  End If
  Leng = Len(Num_)
  Parts = Fix((Leng + 2) / 3)
  If Parts > 7 Then
	B_Only = InNum
	Exit Function
  End If
  For K = 1 To (Parts * 3) - Leng
	Num_ = Insert("0", Num_, 1)
  Next K
  Select Case FracType
	Case 1, 2
	  Select Case Lang
		Case vArabic:  Only = AOnly(Num_, FracS, Single_, Plural, Parts, Sex, 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))
	  
	  End Select
  End Select
  If Only <> "" Then
	Select Case Lang
	  Case vArabic:  B_Only = Only
	End Select
  End If
End Function
'يمكنك تغيير كلمة جنيه بأي معدود مفرد وكلمة جنيهات بأي معدود جمع وكذلك الحال مع الكسر وجنس المعدود أو الكسر (0) للمذكر و (1) للمؤنث
' تم إضافة هذه الملاحظات بواسطة محمد صالح حتى يتم استعمالها في الاستعلامات
Function ArbNum2Text(ByVal InNum, _
			Optional ByVal DecimalPlaces = 2, _
			Optional ByVal FractionType = 4, _
			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 = Format(InNum, "0" & IIf(DecimalPlaces > 0, ".", "") & String(DecimalPlaces, "0"))
	End If
	ArbNum2Text = Negative & S_Only(InNum, vArabic, CByte(FractionType))
	Exit Function
  End If
  If IsNull(DecimalPlaces) Then DecimalPlaces = 2
  InNum = Format(InNum, "0" & IIf(DecimalPlaces > 0, ".", "") & String(DecimalPlaces, "0"))
'If InNum <> Fix(InNum) Then
  If Val(Right(InNum, DecimalPlaces)) > 0 Then
	If myNz(FractionSingle) = Empty Or myNz(FractionPlural) = Empty Then
	  If FractionType > 2 Then FractionType = 1
	End If
  End If
  ' تم إضافة كلمة فقط لا غير في آخر التفقيط بواسطة محمد صالح
   Dim m
   m = " فقطُ لا غيرَ"
  ArbNum2Text = Negative & _
				B_Only(CDec(myNz(InNum, 0)), 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))) & m
End Function


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


تم التعديل بواسطة mohammadey1, 30 April 2012 - 11:24 PM.


#19 محمدي عبد السميع

محمدي عبد السميع
  • Pmembers-2
  • 594 مشاركة
  • Gender:Male

تاريخ المشاركة 30 April 2012 - 09:48 PM

هذا هو الكود الخاص بالتفقيط

ملفات مرفقة



#20 الشهابي

الشهابي
  • EMembers-1
  • 985 مشاركة
  • Gender:Male
  • Location:اليمن - حضرموت - تريم

تاريخ المشاركة 30 April 2012 - 11:05 PM

أخي العزيز / mohammadey1
بارك الله فيك وجزاك الله خير أكواد جميلة
وبالنسبة لاستفسارك

لاادري لماذا تظهر اللغة العربية بهذه الصورة


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

VreoT.gif

ZVBMH.gif





0 عضو (أعضاء) يشاهدون هذا الموضوع

0 الأعضاء, 0 الزوار, 0 مجهولين