نجوم المشاركات

استعمل هذا الكود !!!! Dim Warning As String Warning = MsgBox("أنت الآن على وشك التحديث فهل أنت واثق من رغبتك في التحديث", vbYesNo + vbQuestion, "تحذير") If Warning = vbYes Then DoCmd.SetWarnings (False) ضع هنا استعلام التحديث المطلوب DoCmd.SetWarnings (True) Else DoCmd.CancelEvent End If

هذه طريقة بدون اكواد .... انظر DB1.accdb

وعليكم السلام , طالما انك لا تريد الحل بالأكواد .فلا يمكن عمل هذا الا بهذه المعادلة =IF(A2<>"",IF(AND(B2<>"",CELL("address")=ADDRESS(ROW(A2),COLUMN(A2))),NOW(),IF(CELL("address")<>ADDRESS(ROW(A2),COLUMN(A2)),B2,NOW())),"") الحضور1.xlsx

ممكن تزودنا بعدد من المسارات قبل التعديل والمسار بعد التعديل ؟؟؟؟

جرب كدا وخبرنا ...... Pro-In-Tmt.accdb

مرحبا يوجد في الموقع برنامج من اعداد الاخ @Hosam Shehata ربما يحقق طلبك خصوصا وان البرنامج مفتوح المصدر وصاحبه اتاح التعديل عليه كلمة المرور للادارة 123 كلمة المرور للاستقبال 1 للصلاحيات الكاملة والتحاليل ادخل باسم المستخدم ادارة تحياتي لفتح البرنامج والاطلاع على الجداول والاكواد والتعديل اضع على مفتاح الشفت في لوحة وافتح البرنامج مع استمرار الضغط على الشفت

جرب هذا الملف بالتفصيل Fahad Time Sheet.xlsx

يبدو انك نسيت ان تضغط على ctrl+shift+enter لانها معادلة مصفوفة لذلك لم تعمل معك تفضل إدراج الاسماء تلقائي.xlsx

السلام عليكم أهلا بك أخي الكريم يمكنك ايضا نشر الفيديوهات التعليمية فى جروب الفيس بوك https://www.facebook.com/groups/officena/

مشاركه مع اخوانى واساتذتى جزاهم الله خيرا ع قد حالى اعمل استعلام تحديث واختار حقل الصوره وضع المعيار التالى فى التحديث الى مع تغير كلمه المسار التالى الى المسار الجديد بدون اسم الملف Replace([figura];Left([figura];InStrRev([figura];"\";InStrRev([figura];Right([figura];1))));"D:\photos\") Database2.accdb

انظر المرفق ...... ما هو الداعي لاستخدامها في الاستعلام ( الراتب مسجل في الجدول ) انشئ الاستعلام من الجدول مباشرة أنظر الاستعلام في المرفق .... test (8).accdb

السلام عليكم ورحمة الله وبركاته كل عام وانتم بخير اطلب المسامحة ممن راسلني ولم يجد رد مني هديتي لكم بعد هذه الغيبة Option Explicit '========================================================" ' بسم الله الرحمن الرحيم " '========================================================" ' (دالة تحويل الرقم الى نص باللغة العربية (تفقيط " ' kh_TextNum " '========================================================" 'Num الرقم " '========================================================" 'sex جنس العملة " 'FALSE ( فارغ او صفر مذكر ) " 'TRUE ( أو اي رقم غير الصفر مؤنث ) " '========================================================" 'sNameCurr اسم العملة الرئيسية مفرد " 'pNameCurr اسم العملة الرئيسية جمع " 'NameCurrDec اسم العملة الكسرية " 'Decimal_Count طول الكسر افتراضـياً : بدون اظهار الكسر " '===============================================================================================================================================" 'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" '===============================================================================================================================================" ' ملاحظات ' (اولاً : العملة الرئيسية مثنى (يقوم بها الكود تلقائيا ' مع ملاحظة اذا اسم العملة ينتهي بالتاء المربوطة ' يجب ان يكتب كذلك وليس بالهاء ' ----------------------- ' ثانياً : اذا كانت العملة الرئيسية مفرد فارغاً تعتبر ' اسماء العملات (الجمع والكسري) فارغة تلقائيا ' ----------------------- 'ثالثاً : الكلمة الابتدائية بامكانك تغييرها او تجعلها فارغة Private Const MyBegTx As String = "فقط " ' "" ' ----------------------- ' MyTNum رابعا : يمكنك التغيير (اضافة,حذف,تحرير) في الثابت ' للفئات الصفرية للرقم ادناه Private Const MyTNum As String = "ألف-آلاف/مليون-ملايين/مليار-مليارات/بليون-بلايين/بليار-بليارات/ترليون-ترليونات/تريليار-تريليارات/كدرليون-كدرليونات" '===============================================================================================================================================" 'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" '===============================================================================================================================================" Function kh_TextNum(Num As String, Optional sex As Boolean = False, Optional sNameCurr As String = "", Optional pNameCurr As String = "", Optional NameCurrDec As String = "", Optional Decimal_Count As Byte = 2) As String Dim Spp, zt Dim i%, ii%, pr% Dim MyMid$, nCurr$, Txt$, Txt1$, Txt2$ '====================================== If Not IsNumeric(Num) Then GoTo kh_Exit Spp = Split("/" & MyTNum, "/") ii = UBound(Spp) If Num < 0 Then Num = Abs(Num) '====================================== If Val(Num) > Val(String((ii + 1) * 3, "9") & ".999") Then GoTo kh_Exit '====================================== nCurr = sNameCurr & "-" & IIf(pNameCurr = "", sNameCurr, IIf(sNameCurr = "", "", pNameCurr)) '====================================== Txt1 = Format(Num, String((ii + 1) * 3, "0") & ".000") For i = 0 To ii MyMid = Mid(Txt1, (i * 3) + 1, 3) If MyMid Then zt = Mid(Txt1, (i * 3) + 4, Len(Txt1)) zt = IIf(ii - i, Int(zt), zt) Txt2 = IIf(ii - i, Trim(Spp(ii - i)), nCurr) pr = 1 + IIf(ii - i, 1, CInt(sex)) Txt = Txt & IIf(Len(Txt), " و", "") & kh_nText(MyMid, Txt2, pr, zt, CBool(sNameCurr <> "")) End If If i = ii Then If MyMid = 0 Then Txt = Txt & IIf(Len(Txt), " ", "صفر ") & sNameCurr Next '====================================== Txt = MyBegTx & Txt & kh_dText(Num, sNameCurr, NameCurrDec, Decimal_Count) '====================================== kh_Exit: kh_TextNum = Trim(Txt) End Function ' معالجة العدد من 1 الى 999 لكل فئات الرقم Private Function kh_nText(ByVal iNum As String, ByVal oMm As String, ByVal ibs As Integer, ByVal z As Boolean, ByVal tCu As Boolean) As String Dim Sp Dim Num1%, Num2%, Num3% Dim oM$, S$, S1$, nT$, nT0$, nT1$, nT2$ '====================================== Sp = Split("واحد,إحدى,اثنتان,ثلاث,أربع,خمس,ست,سبع,ثمان,تسع,عشر,إحدى ,اثنتا ", ",") '====================================== If ibs Then S = "ة": Sp(1) = Sp(0): Sp(2) = "اثنان": Sp(11) = "أحد ": Sp(12) = "اثنا " Else S1 = "ة" oM = Trim(Split(oMm, "-")(0)) '====================================== Num1 = Left(iNum, 1) Num2 = Right(iNum, 2) Select Case Num1 Case 1: nT0 = "مائة" Case 2: nT0 = "مائتا" & IIf(ibs = 2, IIf(Num2 < 3, "", "ن"), IIf(Num2 = 0 And oM <> "", "", "ن")) Case 3 To 9: nT0 = Sp(Num1) & "مائة" End Select '========================================= Num1 = Right(iNum, 2) Select Case Num1 Case 1, 2: If nT0 <> "" Then If ibs = 2 Then nT0 = nT0 & " " & oM Case 11 To 99: If oM <> "" Then If ibs Then If z Then oM = oM & "اً" End Select '----------------------------------------- Select Case Num1 Case 1 nT = IIf(oM = "", Sp(0) & S1, oM) oM = IIf(ibs <> 2 And oM <> "", Sp(0) & S1, "") Case 2 nT = IIf(oM = "", Sp(Num1), Replace(oM, "ة", "ت") & IIf(z = 0 And ibs = 2 And tCu, "ا", "ان")) oM = IIf(ibs <> 2 And oM <> "", Sp(Num1), "") Case 3 To 10 oM = Trim(Split(oMm, "-")(1)) nT = Sp(Num1) & S Case 11, 12 nT = Sp(Num1) & Sp(10) & S1 Case 13 To 19 nT = Sp(Num1 - 10) & S & " " & Sp(10) & S1 Case 20 To 99 Num2 = Right(Num1, 1) Num3 = Left(Num1, 1) If Num3 = 2 Then nT1 = "عشرون" Else nT1 = Sp(Num3) & "ون" nT2 = Sp(Num2) & IIf(Num2 > 2, S, "") & " و" & nT1 If Num2 = 0 Then nT2 = nT1 nT = nT2 End Select '====================================== S = IIf(nT = "" Or iNum < 100, "", " و") nT = Replace(nT, Sp(8) & "ة", Sp(8) & "ية") kh_nText = Trim(nT0 & S & nT & " " & oM) '====================================== End Function ' معالجة الكسر Private Function kh_dText(ByVal dNum As String, ByVal NCur As String, ByVal Ndec As String, ByVal co As Byte) As String Dim Td$, Td1$ On Error GoTo 1 If NCur = "" Then Ndec = "" Td = Format(Round(CCur(dNum - Int(dNum)), co), "0." & String(co, "0")) If Td = 0 Or Td = 1 Then Td1 = "": GoTo 1 If Len(Ndec) Then Ndec = " " & Ndec: Td1 = Td * CVar("1" & String(co, "0")) Else Ndec = " " & NCur: Td1 = Td Td1 = " و " & Chr(40) & Td1 & Chr(41) & Ndec 1: kh_dText = Td1 End Function دالة تحويل الرقم الى نص عربي.rar ================================================= الملف المعدل: هذا المرفق بامكانية تفقيط الكسر وامكانية ادخال كلمة نهاية النص دالة تحويل الرقم الى نص عربي.rar ================================================= رابط مباشر للملف

اليكم برنامج دول وعواصم قارة اسيا من هذا الرابط https://top4top.io/downloadf-1616dgrpq1-rar.html وطريقة تسطيب البرنامج تم شرحه فى فيديو دول وعواصم افريقيا السابق وهذا رابط اخر على ميديا فاير برنامج دول وعواصم قارة اسيا

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

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

صديقي جربناها على نظام 32 بت شغالة تمام اما نظام 64 بت لا اعلم

الأخ العزيز @ابو اشرف سلوم في جهازي تظهر رسالة تفيد ان في الكود شيء معين لا يدعم نظام 64 بت الرجاء الإفادة وجزاكم الله خيرا

أحسنت استاذ محمد عمل ممتاز

شكرا لحضرتك على المجهود الرائع و المفيد جعله الله في ميزان حسناتك و رحم الله والديك و حفظكم بالصحة و العافية

"إضافة البيان البحثية تخرج لك فهرسة الإشارات المرجعية باحترافية"، "وهذا ما لا يمكن من خلال الإشارات المرجعية" ليس لديَّ خبرة بالبرمجة، لكن طالما أنك استطعت أن تُظهر فهارس الإشارات المرجعية بملف pdf باحترافية، أعتقد أنك قطعت شوطاً طويلاً للوصول لحل للفهرسة مثل فهرس المحتويات، وفقرة "لا يمكن" حسب ما رأيت منكم ليس في حلها، وإن شاء الله ستصل لفك الشيفرة قريباً وستجد الطريقة المناسبة لذلك، المهم ضع ذلك صوب عينيك أخي الفاضل، ما شاء الله عنك أخي أ. شحادة، وثقتنا بكم عالية. وفقكم الله ورعاكم

بارك الله فيك أخي الكريم على جهودك الطيبة... هل يمكن أن تظهر الفهرسة على ملف الوورد؟

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

تم معالجة الامر الكود Option Explicit Sub Get_ALL() Dim Arr(), m, I, itm Dim Ro%, Col%, My_sum# Dim k% m = 1 Principal.Range("B7:B13").ClearContents If Application.CountA(Principal.Range("B4:B6")) < 3 Then MsgBox "Incomplete Data" & Chr(10) & _ "Ckeck Up For Empty The Cells,B4,B5,And B6" Exit Sub End If If Principal.Range("B4") > Sheets.Count - 1 Then Principal.Range("B4") = 1 End If If Principal.Range("B5") > Sheets.Count - 1 Then Principal.Range("B5") = Sheets.Count - 1 End If If Principal.Range("B5") < Principal.Range("B4") Then Principal.Range("B5") = Principal.Range("B4") End If m = 1 For I = Principal.Range("B4") To Principal.Range("B5") ReDim Preserve Arr(1 To m) Arr(m) = Sheets(Principal.Range("B4") + m).Name m = m + 1 Next '++++++++++++++++++++++++++++++++++ For k = 7 To 13 For Each itm In Arr Ro = Sheets(itm).Range("B4:B21").Find(Principal.Range("B6"), lookat:=1).Row Col = Sheets(itm).Range("C3:Z3").Find(Principal.Range("A" & k), lookat:=1).Column + 2 My_sum = My_sum + Val(Sheets(itm).Cells(Ro, Col)) Next itm Principal.Range("B" & k).Value = My_sum My_sum = 0 Next k End Sub الملف مرفق MaKhazin.xlsm

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

ما شاء الله تبارك الله الحمد لله رب العالمين بارك الله فيك اخي علاء بالتوفيق .....

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

ضع هذا في المديول Function salary1(frm As String) If Forms(frm)!المهنة = "طبيب" Then Forms(frm)!الراتب = 10000 ElseIf Forms(frm)!المهنة = "مهندس" Then Forms(frm)!الراتب = 9000 ElseIf Forms(frm)!المهنة = "صيدلي" Then Forms(frm)!الراتب = 8000 ElseIf Forms(frm)!المهنة = "معاون طبيب" Then Forms(frm)!الراتب = 7000 ElseIf Forms(frm)!المهنة = "معاون مهندي" Then Forms(frm)!الراتب = 6000 ElseIf Forms(frm)!المهنة = "" Then Forms(frm)!الراتب = 0 End If End Function استدعيه من النموذج بهذا الكود Call salary1(Me.Name) DoCmd.RefreshRecord

السلام عليكم ورحمة الله عفوا اخى الكريم اجعل الكود بهذا الشكل يعمل معك مدى الحياة فقط يمكنك التعديل من خلال الكود الخلية تريد ظهور التاريخ فيها و الشكر موصول لاخى الرائد77 Private Sub Workbook_Open() Dim i As Integer i = Year(Date) j = Month(Date) If j < 7 Then Sheets("Sheet3").Range("A1").Value = "7 / 1 / " & i - 1 Else Sheets("Sheet3").Range("A1").Value = "7 / 1 / " & i End If End Sub

استاذنا الفاضل / @ahmed_proff انت استاذ عظيم وفاضل وشرحك فى قمة الجمال وانا متابع كل شروحاتك واستفدت كثيرا فعلا انت بروف الله يرحم والدك فى هذه الايام المباركة كل الاحترام والتقدير لكم

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

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

لكي لا تغيب املك انا عملت هذا لكن بعد شغل كتير راح نواصل ان شاء الله اتفضل شوف هذا هل يعجبك حتى الان اذا بيعجبك ادعي لي ولاهلي مع تقدير جمعية الخيرية.rar

السلام عليكم ورحمة الله وبركاته الاخ الحبيب/ azeem ______حفظه الله جزاك الله خيرا وبارك الله فيك الاخ الحبيب/ الجزيرة______حفظه الله المنتدى منور بشخصك الكريم رجاءك مقبول جزاك الله خيرا وبارك الله فيك الاخ الحبيب/ عبدالله المجرب______حفظه الله المنتدى منور بشخصك الكريم جزاك الله خيرا وبارك الله فيك الاخ الحبيب/ ابوعبدالله______حفظه الله المنتدى منور بشخصك الكريم هذا العمل من ثمرة العمل السابق الذي لك باع كبير في انجازه جزاك الله خيرا وبارك الله فيك الاخ الحبيب/ سعد عابد______حفظه الله نعم صدقت جزاك الله خيرا وبارك الله فيك الاخ الحبيب/ محمد صالح ______حفظه الله تدعوا الله ان يمن علينا وعليكم وعلى جميع المسلمين بالامن والامان تم التنفيذ في الملف المرفق جزاك الله خيرا وبارك الله فيك الاخ الحبيب/ alidroos______حفظه الله الله يكرمك في الدارين جزاك الله خيرا وبارك الله فيك الاخ الحبيب/ معتصم محمد______حفظه الله شكرا جزيلا والغاية من وضع اي عمل هو طرح افكاروطرق مختلفة وانا مستعد لشرح اي جزئية غامضة جزاك الله خيرا وبارك الله فيك الاخ الحبيب/ سعيد______حفظه الله الله يكرمك في الدارين جزاك الله خيرا وبارك الله فيك الاخ الحبيب/ يحياوي______حفظه الله الله يكرمك في الدارين جزاك الله خيرا وبارك الله فيك الاخ الحبيب/ فضل 1______حفظه الله الله يكرمك في الدارين جزاك الله خيرا وبارك الله فيك الاخ الحبيب/ الشهابي______حفظه الله الله يكرمك في الدارين جزاك الله خيرا وبارك الله فيك الاخ الحبيب/نادر______حفظه الله الله يكرمك في الدارين ورجاءك مقبول جزاك الله خيرا وبارك الله فيك الاخ الحبيب/ محمدي______حفظه الله الله يكرمك في الدارين جزاك الله خيرا وبارك الله فيك الاخ الحبيب/ طاهر______حفظه الله الله يكرمك في الدارين جزاك الله خيرا وبارك الله فيك الاخ الحبيب/الحسامي______حفظه الله الله يكرمك في الدارين جزاك الله خيرا وبارك الله فيك الاخ الحبيب/دغيدي______حفظه الله شاهد التعديل في المرفق واي ملاحظات اشعرنا بها جزاك الله خيرا وبارك الله فيك ========================================================================= هذه الدالة مع امكانية تفقيط الكسر Option Explicit '========================================================" ' بسم الله الرحمن الرحيم " '========================================================" ' (دالة تحويل الرقم الى نص باللغة العربية (تفقيط " ' kh_TextNum " '========================================================" 'Num الرقم " '========================================================" 'Sex جنس العملة " ' FALSE ( أو فارغ او صفر مذكر ) " ' TRUE ( أو اي رقم غير الصفر مؤنث ) " '========================================================" 'NCurr_Si اسم العملة الرئيسية مفرد " 'NCurr_Pl اسم العملة الرئيسية جمع " 'NCurrDec_Si اسم العملة الكسرية " 'Decimal_Count طول الكسر افتراضـياً : بدون اظهار الكسر " '========================================================" ' : للدلالة على تفقيط الكسر عين التالي " 'NCurrDec_pl اسم العملة الكسرية جمع " 'dSex جنس عملة الكسر " ' FALSE ( أو فارغ او صفر مذكر ) " ' TRUE ( أو اي رقم غير الصفر مؤنث ) " '========================================================" 'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" ' ملاحظات ' (اولاً : العملة الرئيسية مثنى (يقوم بها الكود تلقائيا ' مع ملاحظة اذا اسم العملة ينتهي بالتاء المربوطة ' يجب ان يكتب كذلك وليس بالهاء ' ----------------------- ' ثانياً : اذا كانت العملة الرئيسية مفرد فارغاً تعتبر ' اسماء العملات (الجمع والكسري) فارغة تلقائيا ' ----------------------- '("" ثالثاً : امكانية إضافة كلمة بداية ونهاية النص (فارغة Private Const MyBegTx As String = "فقط " Private Const MyEndTx As String = "" ' ----------------------- ' MyTNum رابعا : يمكنك التغيير (اضافة,حذف,تحرير) في الثابت ' للفئات الصفرية للرقم ادناه Private Const MyTNum As String = "ألف-آلاف/مليون-ملايين/مليار-مليارات/بليون-بلايين/بليار-بليارات/ترليون-ترليونات/تريليار-تريليارات/كدرليون-كدرليونات" 'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" '===============================================================================================================================================" Private Const wow As String * 2 = " و" '===============================================================================================================================================" Function kh_TextNum(Num As String, Optional Sex As Boolean = False _ , Optional NCurr_Si As String = "", Optional NCurr_Pl As String = "" _ , Optional NCurrDec_Si As String = "", Optional Decimal_Count As Byte = 0 _ , Optional NCurrDec_Pl As String = "", Optional dSex As Boolean = False) As String '====================================== Dim Spp, zt Dim i%, ii%, pr% Dim MyMid$, nCurr$, Txt$, Txt1$, Txt2$ '====================================== If Not IsNumeric(Num) Then GoTo kh_Exit If Num = 0 Then Txt = MyBegTx & "صفر " & NCurr_Si: GoTo kh_Exit '====================================== Spp = Split("/" & MyTNum, "/") ii = UBound(Spp) If Num < 0 Then Num = Abs(Num) '====================================== If Val(Num) > Val(String((ii + 1) * 3, "9") & ".999") Then GoTo kh_Exit '====================================== nCurr = NCurr_Si & "-" & IIf(NCurr_Pl = "", NCurr_Si, IIf(NCurr_Si = "", "", NCurr_Pl)) '====================================== Txt1 = Format(Num, String((ii + 1) * 3, "0") & ".000") For i = 0 To ii MyMid = Mid(Txt1, (i * 3) + 1, 3) If MyMid Then zt = Mid(Txt1, (i * 3) + 4, Len(Txt1)) zt = IIf(ii - i, Int(zt), 1) Txt2 = IIf(ii - i, Trim(Spp(ii - i)), nCurr) pr = 1 + IIf(ii - i, 1, CInt(Sex)) Txt = Txt & IIf(Len(Txt), wow, "") & kh_nText(MyMid, Txt2, pr, zt, CBool(NCurr_Si <> "")) End If If i = ii Then If MyMid = 0 Then Txt = Txt & IIf(Len(Txt), " " & NCurr_Si, IIf(Decimal_Count = 0, "صفر", "")) Next '====================================== Txt = MyBegTx & Txt & kh_dText(Num, NCurr_Si, Trim(NCurrDec_Si), Decimal_Count, Trim(NCurrDec_Pl), dSex) & MyEndTx '====================================== kh_Exit: kh_TextNum = Trim(Txt) End Function ' معالجة العدد من 1 الى 999 لكل فئات الرقم Private Function kh_nText(ByVal iNum As String, ByVal oMm As String, ByVal ibs As Integer, ByVal Z As Boolean, ByVal tCu As Boolean) As String Dim Sp Dim Num1%, Num2%, Num3% Dim oM$, S$, S1$, nT$, nT0$, nT1$, nT2$ '====================================== Sp = Split("واحد,إحدى,اثنتان,ثلاث,أربع,خمس,ست,سبع,ثمان,تسع,عشر,إحدى ,اثنتا ", ",") '====================================== If ibs Then S = "ة": Sp(1) = Sp(0): Sp(2) = "اثنان": Sp(11) = "أحد ": Sp(12) = "اثنا " Else S1 = "ة" oM = Trim(Split(oMm, "-")(0)) '====================================== Num1 = Left(iNum, 1) Num2 = Right(iNum, 2) Select Case Num1 Case 1: nT0 = "مائة" Case 2: nT0 = "مائتا" & IIf(ibs = 2, IIf(Num2 < 3, "", "ن"), IIf(Num2 = 0 And oM <> "", "", "ن")) Case 3 To 9: nT0 = Sp(Num1) & "مائة" End Select '========================================= Num1 = Right(iNum, 2) Select Case Num1 Case 1, 2: If nT0 <> "" Then If ibs = 2 Then nT0 = nT0 & " " & oM Case 11 To 99: If oM <> "" Then If ibs Then If Z Then oM = oM & "اً" End Select '----------------------------------------- Select Case Num1 Case 1 nT = IIf(oM = "", Sp(0) & S1, oM) oM = IIf(ibs <> 2 And oM <> "", Sp(0) & S1, "") Case 2 nT = IIf(oM = "", Sp(Num1), Replace(oM, "ة", "ت") & IIf(Z = 0 And ibs = 2 And tCu, "ا", "ان")) oM = IIf(ibs <> 2 And oM <> "", Sp(Num1), "") Case 3 To 10 oM = Trim(Split(oMm, "-")(1)) nT = Sp(Num1) & S Case 11, 12 nT = Sp(Num1) & Sp(10) & S1 Case 13 To 19 nT = Sp(Num1 - 10) & S & " " & Sp(10) & S1 Case 20 To 99 Num2 = Right(Num1, 1) Num3 = Left(Num1, 1) If Num3 = 2 Then nT1 = "عشرون" Else nT1 = Sp(Num3) & "ون" nT2 = Sp(Num2) & IIf(Num2 > 2, S, "") & wow & nT1 If Num2 = 0 Then nT2 = nT1 nT = nT2 End Select '====================================== S = IIf(nT = "" Or iNum < 100, "", wow) nT = Replace(nT, Sp(8) & "ة", Sp(8) & "ية") kh_nText = Trim(nT0 & S & nT & " " & oM) '====================================== End Function ' معالجة الكسر Private Function kh_dText(ByVal dNum As String, ByVal NCur As String, ByVal Ndec As String, ByVal co As Byte, ByVal Ndec_pl As String, ByVal dsx As Boolean) As String Dim Td$, dwow$, Td1$ On Error GoTo 1 If co = 0 Then GoTo 1 If NCur = "" Then Ndec = "" Td = Format(Round(CCur(dNum - Int(dNum)), co), "0." & String(co, "0")) If Td = 0 Or Td = 1 Then Td1 = "": GoTo 1 If Int(dNum) Then dwow = wow If Len(Ndec) Then Ndec = " " & Ndec Td1 = Td * CVar("1" & String(co, "0")) If Len(Ndec_pl) And co < 4 Then Td1 = dwow & kh_nText(Format(Td1, "000"), Ndec & "-" & Ndec_pl, 1 + CInt(dsx), 1, 0): GoTo 1 Else Ndec = " " & NCur: Td1 = Td End If Td1 = dwow & " " & Chr(40) & Td1 & Chr(41) & Ndec 1: kh_dText = Td1 End Function دالة تحويل الرقم الى نص عربي.rar