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

[محمدي عبد السميع]

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

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

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

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

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

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

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

وبعد :

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

عمل ولا أروع منه في مجال أعمال الكنترول الخاص برجال التربية والتعليم

وسنطلق على هذا العمل " درة أعمال الكنترول "

بسم الله نبدأ

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

*** حساب العمر عند يوم واحد أكوبر من العام الدراسي القادم

وتوجد معادلات كثيرة لكن أفضلها وأسهلها على الإطلاق هذه المعادلات

=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

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

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

حساب العمر.rar

حساب السن بالكود.rar

كود اخفاء الصفوف.rar

الخلية النشطة.rar

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

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

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

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

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

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

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

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

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

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

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

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

[محمدي عبد السميع]

يتبقى لنا في الصفحة الاساسية بضع معادلات لتضبط عملية ادخال البيانات بدقة

=SUMPRODUCT(--(INDEX(البيانات;0;3)="ولد");--(INDEX(البيانات;0;8)="مسلم"))

وهذه المعادلة تعني عدد الاولاد المسلمين

=SUMPRODUCT(--(INDEX(البيانات;0;3)="بنت");--(INDEX(البيانات;0;8)="مسلمة"))

وهذه المعادلة تعني عدد البنات المسلمات

وهذه المعادلات ستفيد في دقة الاعداد المدخلة ونوعيتها

فإذا تمت المدخلات صحيحة ستجد على الفور كلمة أحسنت

[محمدي عبد السميع]

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

صفحة بيانات أساسية.rar

[محمدي عبد السميع]

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

بارك الله في العلامة عبد الله باقشير

ونحن - ( الأستاذ محمدي عبد السميع ) - والجميع معه

وللحديث بقية

لجان خنوريه.rar

[كعبلاوى]

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

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

اخي محمدي

تم افتتاح مكتبة الاكواد وهذا رابطه

http://www.officena.net/ib/index.php?app=downloads&showcat=16

لما لا تستغله في هذه السلسلة التعليمية حتي يسهل الرجوع اليه

والامر متروك لك

[حسين شاكر]

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

[محمدي عبد السميع]

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

الاخ عبد الله

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

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

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

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

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

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

[محمدي عبد السميع]

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

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

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

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

اخفاء الأعمدة.rar

إخفاء و إظهار أشرطة القوائم والأدوات.rar

[محمدي عبد السميع]

كود للفرز

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

وكثير غيرهم

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

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

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

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

فرز.rar

[محمدي عبد السميع]

كودان مهمان

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

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

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

آمين

لإزالة كافة المسافات في النص ماعدا المسافات المفردة.rar

خروج من الملف.rar

[جلال هشام]

Thank for every thing

[محمدي عبد السميع]

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

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

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

آمين

معاينة طباعة.rar

معاينة طباعة مع امكانية الطباعه.rar

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

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

وفقك الله اخي محمدي في مجهودك هذا

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

وبالتوفيق في كل اعمالك

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

[محمدي عبد السميع]

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

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

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

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

[محمدي عبد السميع]

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

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

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

*********

وأنا سائل أخاً إنتفع بشيء من الموضوع

أن يدعو لي ولوالدي ، ومشايخي ، وسائر أحبابنا ، أجمعين،وكل من ساهم بكود او عمل ينتفع به

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

وعلى الله الكريم اعتمادي ، وإليه تفويضي واستنادي، وحسببي الله ونعم الوكيل، ولا حول ولا قوة إلا بالله العزيز الحكيم

كود حساب العمر بالتاريخ الميلادي.rar

كود حساب العمر بالتاريخ الهجري.rar

واجهه برنامج كنترول.rar

[محمدي عبد السميع]

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

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

[/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

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

التنقل بين الصفحات.rar

[محمدي عبد السميع]

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

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

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

'-- 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

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

تم تعديل أبريل 30, 2012 بواسطه mohammadey1

[محمدي عبد السميع]

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

كود تفقيط مفيد باستخدامات مختلفة.rar

[الشهابي]

أخي العزيز / mohammadey1

بارك الله فيك وجزاك الله خير أكواد جميلة

وبالنسبة لاستفسارك

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

هناك فائدة لأستاذنا عبد الله باقشير وهي :

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

ثم انسخ الكود

[محمدي عبد السميع]

كود آخر للتفقيط

ولاأروع منه للعالم العلامة عبد الله باقشير

دالة تحويل الرقم الى نص عربي.rar

[محمدي عبد السميع]

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

الحمد لله الواحد القهار، العزيز الغفار،مكور الليل على النهار ،

تذكرة لأولي القلوب والأبصار وتبصرة لذوي الألباب والاعتبار ،

الذي أيقظ من خلقه من اصطفاه فزهدهم في هذه الدار،

وشغلهم بمراقبته وإدامة الأفكار ،

وملازمة الاتعاظ والادكار،

ووفقهم للدؤوب في طاعته والتأهب لدار القرار،

والحذر مما يسخطه ويوجب دار البوار،

والمحافظة على ذلك مع تغاير الأحوال والأطوار.

أحمده أبلغ حمد وأزكاه، وأشمله وأنماه.

أما بعد:

رأيت أن أقدم عملا خالصا لوجه الله الكريم لعل الله يتغمدنا برحمته

ولذا رأيت أن أجمع الأكواد بطريقة منظمة تسهل للجميع الحصول عليها عند استخدام محرك البحث ،

ولهذا ساقدم

سلسلة من الأكواد كل كود بعنوان واضح يسهل الوصول له

في موضوع مستقل

وسأشرح كيفية استخدام الكود ماتيسر لي

إن شاء الله

وعلى الله قصد السبيل

******************************************

الكود الاول هذا كود يجعل صفحة الاكسيل

عندما تكتب فيها تكتب باللغة العربيه دائما

حتى ولو كانت لغة الكتابة في لوحة المفاتيح انجليزي

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

افتح ملف اكسيل

اضغط على الرز ALT وانت ضاغط على الزر

اضغط على F11 الموجود أعلا لوحة المفاتيح

ستظهر شاشة الماكرو

اضغط على This Workbook ستجد

Private Sub Workbook_Open()

hosami "00000401", 1

End Sub

انسخه

والصقة في ملفك الجديد في نفس الموقع This Workbook

ثم

اضغط على موديول 1

سيتم فتح الموديول هذا

Declare Function hosami Lib _

"user32" Alias "LoadKeyboardLayoutA" (ByVal A As String _

, ByVal B As Long) As Long

انسخه وضعه في نفس المكان وهو موديول 1 في ملفك الجديد

احفظ الملف واعد فتحه ولاحظ لغة الكتابه في لوحة المفاتيح

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

تغيير لغة الكي بورد الى العربي.rar

تغيير لغة الكي بورد الى العربي بطريقة اخرى.rar

[احمد عطية رزق]

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

[بوحماد]

بارك الله فيك

[ايمن ابو علام]

مااروع هذه الاعمال .الشكر كل الشكر لرجال هذا المنتدى العظيم