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

السلام عليكم ورحمة الله وبركاته هذه دعوة كريمة لتجربة الأداة الجديدة والفريدة من نوعها : دكتور ال VBA وضائف الأداة : 1- تحويل الكود إلى صيغة متوافقة مع النواتين 32 و 64 بت. 2- تصحيح الأخطاء البرمجية في الكود. 3- تنسيق وترتيب الكود شكليا. 4- كتابة التعليقات وشرح للكود باللغتين العربية والإنجليزية. 5- إضافة صائد الأخطاء للكود وذلك لتعقب الأخطاء البرمجية. 6- إضافة ترقيم لأسطر الكود. يمكنك اختيار واحد من هذه الوظائف أو تختار من بينها ما تريده. الأداة مخصصة لأكواد ال VBA وتعتمد على قدرات الذكاء الاصطناعي لإعطاء نتائج دقيقة ومبهرة .. 😁✌🏻 اختصر على نفسك الوقت والجهد واعمل بذكاء 😉👌🏻 رابط الأداة : https://vba-code-doctor-471932697586.us-west1.run.app/ يمكنك فتحها في الهاتف أو الحاسوب على راحتك 😎🌷 جربوها وعطوني رأيكم 😇✌🏻

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

وعليكم السلام ورحمة الله وبركاته الى جانب الحلول التي ارفقها استاذنا الفاضل hegazee اليك حل اخر بالكود في حدث الورقة Private Sub Worksheet_Change(ByVal Target As Range) Dim rngF As Range, rngG As Range Dim rngB As Range, rngC As Range Dim pos As Variant Set rngF = Me.Range("F2") ' Set rngG = Me.Range("G2") Set rngB = Me.Range("B2:B1000") Set rngC = Me.Range("C2:C1000") If Not Intersect(Target, rngF) Is Nothing Then Application.EnableEvents = False pos = Application.Match(rngF.Value, rngB, 0) If Not IsError(pos) Then rngG.Value = Application.Index(rngC, pos) Else rngG.Value = "" End If Application.EnableEvents = True End If rngG.Select End Sub data.xlsb

بعد إذن مهندسنا الغالي .. إذا كان ملفك بصيغة Accde فلن تصل للأكواد أبداً .

لا عليك أخي عبداللطيف ، المهم ان المشكلة تم حلها .

تفضل التعديل التالي .. جربه وأخبرني بالنتيجة . 123452025.zip

بارك الله فيكم وينكم من زمان هذا الموضوع طرحته اليوم بعد وصولي لنتيجة صحيحة مرضية بل محكمة هذا الوصول سبقه موضوع تجاوزت المشاركات فيه الــــ 100 لن اتنازل عن اكوادي التي صنعتها .. مادام العمل سليم .. لاني تعبت من التجربة والتكرار والبحث عن الطريقة السليمة ..... ولكن ستبقى هذه الأكواد التي تفضلتم بها مرجعا مهما لي ولغيري لمن اراد بناء برنامج حضور كي يستنير بها حفظكم الله من كل سوء وزادكم علما ورفعة

رداً على هذه النقطة ، وحيث أنه سبق تنفيذها سابقاً .. جرب المرفق نفسه بعد التعديل بحيث سيتم فقط عرض الخطوط العربية ( أو التي تتعامل مع الكاركتر العربي ) في الكومبوبوكس . مع إضافة الفرز التصاعدي للأسماء :- Db3.zip

وانا عند وعدى هذه مشاركتى 1- بعد فك الضغط انقل الصور الى المجلد : TempResources 2- قم بفتح قاعدة البيانات 3- فى المستقبل فقط اضف اى صور الى المجلد : TempResources فى جزء لم انته منه بعد حفظ الاعدادت كقوالب او حفظ الاعدادت لكل شهادة ان اردنا ان تكون كقاعدة بيانات للاحتفاظ بالبيانت وليس مجرد موديولر لعمل الشهادات ويتبقى الجزء الاخير انا افكر فى الطباعة من النموذج الفرعى بشكل مباشر بدون اى تقارير الى لقاء قريب بعد ان اعرف ارائكم فى التطبيق والافكار البسيطة المتواضعة

فكرتي المتواضعة .. dbs2.zip

بل اعجبني المشهد .. سلمت اناملك يا سلام .. زاد حماسي .. احب المفاجآت في مثل هذه المواضيع

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

فضلت ابحث فى المنتدى عن موضوع صفحة رئيسية لاستاذ ابو جودي الى ان وجدت الموضوع طيب المرفق الاول على طريقة ابو جودي والمرفق الثانى من هذا الموضوع والذى يخص الاستاذ Foksh قمت بتعديل بسيط واضافة بسيطة جدا قائمة جانبية على طريقة ابو جودى.zip قائمة جانبية على طريقة الاستاذ Foksh.zip

الملف بعد تحويله لـــ 2003 دون الدخول بأي شئ فقط التحويل . UnMatched.mdb

و عليكم السلام ورحمة الله و بركاته https://www.officena.net/ib/topic/64613-أبغي-قائمة-منسدلة-مرتبطة-بقائمة-منسدلة-أخري-فى-نفس-ورقة-العمل/

تم المطلوب في الملف المرفق... حافز.xlsx

مشاركة مع تنفيذ فكرة أستاذنا @kkhalifa1960 ، وبدلاً من الإعتماد على نموذج فرعي للقائمة الفرعية ، هذا تعديل على الفكرة التي تم طرحها سابقاً ، بحيث تم تطبيقها وكأنها Navigation Form .. الملف المرفق :- Menu Navigations.zip

تفضل أخي الكريم / ملفك بعد التعديل وتوسيع النطاق في العمل . وأرجو منك الإهتمام بمواضيعك وأغلاق ما يستحق الإغلاق إشعاراً للقارئ بأن الموضوع قد تم حله والإجابة عليه . فتفاعلك يعكس فكرك . UnMatched123.zip

هل المطلوب ايقونة واحدة ام ممكن ان تكون اكثر من واحدة

استاذنا الخبير المتألق @Foksh اشكرك كل الشكر ,, وسع الله رزقك وزادك علما وكفاك شرور الناس

الحمد لله الذي بنعمته تتم الصالحات

السلام عليكم محاولة بسيطة... New Microsoft Access Database.rar

هذا حسابي الاخر من العمل اشكرك معلمنا الغالي @Foksh تم حل المشكلة لما ارجع ع البيت مساءا سأضع اجابة صحيحه

سأوافيك بها غدا بحول الله

ما شاء الله تبارك الرحمن 🙂 جميل جدا تنوع الأفكار في نفس المجال 😊👌 وأنا أيضا لدي برنامج خاص بتصميم الشهادات وتنسيقها وتوليد الشهادات لمجموعة كبيرة من الطلاب أو المتدربين أو المستلمين بشكل عام ، وكذلك يقوم بإرسال الشهادات بالبريد الإلكتروني لكل المستهدفين ( كل متدرب أو طالب يستلم شهادته) ، وأيضا يقوم بحفظ جميع الشهادات على شكل Pdf دفعة واحدة .. 🙂 مع إمكانيات تنسيق النص ( الخطوط والألوان ) بشكل حر ، وإضافة التواقيع ، وتغيير إطارات البرنامج .. إلخ تصميم وتنسيق النصوص بكل أريحية إضافة المتدربين دفعة واحدة بعدد لا محدود معاينة بشكل مباشر اواجهة البرنامج مع خيارات البحث وعرض تقارير وإحصائيات لتحميل البرنامج : تنصيب برنامج صانع الشهادات الإصدار الثالث 3.0.zip

نعم .. تماما السر في هذه الدالة التي حلت المشكلة الدالة تتحدث وليست بحاجة الى شرح .. حيث تفحص الوقت الحالي هل هو في مساء اليوم ام لا Dim startTime As Date Dim endTime As Date Dim currentTime As Date Dim i As Integer startTime = TimeValue("12:01:00") endTime = TimeValue("23:59:59") currentTime = Time() If currentTime > startTime And currentTime < endTime Then i = 1 Else i = 2 End If CheckTimeBetween = i وكان السبب الرئيس في المشكلة هو دالة توقيت المساء سواء الحضور او الانصراف لأنه عند دخول اليوم التالي يعتبر الدخول المسائي ضمن مساء الغد لهذا تم تعديل دالتي التوقيت المسائي وفقا لهذه الدالة اعلاه انظروا كيف تتعامل الدالتان ادناه الشرط يقول : اذا الوقت الحالي داخل في شرط الدالة وصحيح .. اي =1 فالتاريخ تاريخ اليوم وإلا فإن التاريخ هو تاريخ الأمس Public Function funFirstTimeB_in() Dim z As Integer Dim i As Date, ii As Date, jj As Date z = Nz(DLookup("free2_in", "tblTimeCtrl"), 0) If CheckTimeBetween() = 1 Then i = DLookup("fatrah2_In", "tblTimeCtrl") & " " & Date ii = DateAdd("n", -z, i) Else jj = DateAdd("d", -1, Date) i = DLookup("fatrah2_In", "tblTimeCtrl") & " " & jj ii = DateAdd("n", -z, i) End If funFirstTimeB_in = ii End Function Public Function funLastTimeB_Out() Dim z As Integer Dim x As Integer, xx As Integer Dim i As Date, ii As Date, jj As Date z = Nz(DLookup("free2_out", "tblTimeCtrl"), 0) x = Nz(DLookup("hours_Work2", "tblTimeCtrl"), 0) xx = (x * 60) + z If CheckTimeBetween() = 1 Then i = DLookup("fatrah2_In", "tblTimeCtrl") & " " & Date ii = DateAdd("n", xx, i) Else jj = DateAdd("d", -1, Date) i = DLookup("fatrah2_In", "tblTimeCtrl") & " " & jj ii = DateAdd("n", xx, i) End If funLastTimeB_Out = ii End Function للتجربة والتأكد ان كل شيء تمام جعلت عند التوقيع في الفترتين كليهما .. تظهر رسالتان الاولى لبداية التوقيع والثانية لنهايته اذا الامور تمام يمكنك تعطيل وايقاف هذه الرسائل بداية التوقيع = وقت الدخول الرسمي - الوقت المتاح قبل نهاية التوقيع = وقت الدخول الرسمي + عدد ساعات العمل + الوقت المتاح بعد جعلت الاوقات المتاحة بالدقائق من اجل دقة الاختيار

هذه تفيد بأن أحد المكتبات ناقصة أو مفقودة أو احد الاكواد يعمل عل 32 بت وانت نقلتها على جهاز يعمل على 64 بت . وللاسف انا كما قلت لك انا حولت الملف فقط والباقي عند الاستاذ @Foksh . هو صاحب الموضوع .................... تحياتي لك .

نعم هذا هو المفترض في جميع الانظمة المتعارف عليها .. التوقيع الأول = حضور سواء جاء اول الوقت او آخره الأصل ان البرنامج يجب ان يعرفهم واحدا واحدا ، ويعرف اوقاتهم المتاح لهم التوقيع فيها . انا صنعت ذلك باحكام .. ولكن طلب الاخ محمد فيما لو تجاوز الوقت اليوم الحالي الى ما بعد منتصف الليل ودخول يوم جديد هنا المعيار الاساسي يكون حجر عثرة ويجب ازالته والبحث عن بديل .. وهنا جاءت الثغرات ...................... بعد كل المحاولات اتضح لي انه من اجل الضبط المحكم ( ما يخرش المية ) يجب اضافة فترة جديدة تخص اليوم التالي هنا يصبح لدينا ثلاث فترات على الأقل .. ويمكن زيادة عدد الفترات عن 3 لمن اراد .. وكل ذلك خلال 24 ساعة تبدأ من الساعة 12:01 صباحا وتنتهي في 11:59 مساء .. حسب تقسيم كل فترة بداية/نهاية ان وافقني على هذا المقترح سوف اقوم باعداده سواء على طريقة تصميم حقلين في الجدول حضور/انصراف //// او طريقة الحقل الواحد والمعرف

السلام عليكم تم تعديل المعادلات حسب ما تريد (حسب فهمي) في الملف المرفق... مخصصات.xlsx

السلام عليكم ,, ماشاء الله فكره جميله , وجميع الخبراء اجتمعو للحل السريع , واستفدت من افكاركم بارك الله بكم جميعا ,, لكن عندي سؤال للخبير في فنون الاكسس ,والصديق @Foksh كيف قمت بعمل اخفاء وحماية السجلات .

عجيب .. عجيب يبدو انك عدلت على شيء ما اعدت التجربة .. والنتيجة كانت مذهلة التعديلات التي اجراها : تنظيم الكود .. بحيث جعل جميع الاعلانات عن المتغيرات في الأعلى بدل شرط الحقل النصي في الدوال بالمتغير وكذلك في جملة sql استبدل الدالة بالمتغير .. عفريت برمجي اضاف لي متغير اسم الموظف غفلت عن نقله من العمل السابق ... هذه الاضافة لا تخطر على بال المحترفين الا بعد عناء اغلاق السجلات عند نهاية كل شرط .. الحقيقة هذه الحركة تحفة هذه صورة من الخيارات التي استخدمتها : وهذا الكود الاصلي : Private Sub id_AfterUpdate() EmpUserid = id Dim mylevl As Boolean mylevl = Nz(DLookup("Emp_user", "tblEmpNames", "Emp_user='" & Me.id & "'"), 0) EmpFatrah = Nz(DLookup("fatrah", "tblEmpNames", "Emp_user='" & Me.id & "'"), 0) If mylevl = False Then Beep Me.LabelH.Caption = "خطأ!! .. الادخال غير صحيح" Me.TimerInterval = 3000 id = "" id.SetFocus Exit Sub End If Dim rs As Recordset Dim strSql As String strSql = "SELECT TOP 1 tblCheckINOut.id, tblCheckINOut.EmpUser, tblCheckINOut.chekInOut, tblCheckINOut.chkio, tblCheckINOut.ftra_id " & vbCrLf & _ "FROM tblCheckINOut " & vbCrLf & _ "WHERE (((tblCheckINOut.EmpUser)=funEmpUserid())) " & vbCrLf & _ "ORDER BY tblCheckINOut.id DESC;" Set rs = CurrentDb.OpenRecordset(strSql) If rs.RecordCount = 0 Then rs.AddNew rs!EmpUser = id rs!chekInOut = Now() rs!chkio = "I" rs!ftra_id = EmpFatrah Me.txtnm = empName LabelH.Caption = "حضور" Me.Requery Me.TimerInterval = 3000 Me.id = "" Me.id.SetFocus rs.Update Exit Sub End If Dim waitTime As Integer Dim AdTim As Date waitTime = Nz(DLookup("waitBtween", "tblTimeCtrl"), 0) AdTim = DateAdd("n", waitTime, rs!chekInOut) If Now() < AdTim Then Me.id.SetFocus Beep Me.LabelH.Caption = "توقيع مكرر !! انتظر قليلا ..." id = "" Me.TimerInterval = 3000 id.SetFocus Exit Sub Else If rs!chkio = "I" Then rs.AddNew rs!EmpUser = EmpUserid rs!chekInOut = Now() rs!chkio = "O" rs!ftra_id = EmpFatrah Me.txtnm = empName LabelH.Caption = "انصراف" Me.Requery Me.id = "" Me.TimerInterval = 3000 Me.id.SetFocus rs.Update Exit Sub ElseIf rs!chkio = "O" Then rs.AddNew rs!EmpUser = EmpUserid rs!chekInOut = Now() rs!chkio = "I" rs!ftra_id = EmpFatrah Me.txtnm = empName LabelH.Caption = "حضور" Me.Requery Me.TimerInterval = 3000 Me.id = "" Me.id.SetFocus rs.Update Exit Sub End If End If End Sub وهذه هي النتيجة الرائعة : Private Sub id_AfterUpdate() Dim EmpUserid As Variant Dim mylevl As Boolean Dim EmpFatrah As Variant Dim rs As DAO.Recordset Dim strSql As String Dim waitTime As Integer Dim AdTim As Date Dim empName As String ' Declare empName EmpUserid = Me.id ' Corrected logic for mylevl to check for user existence mylevl = Not IsNull(DLookup("Emp_user", "tblEmpNames", "Emp_user='" & EmpUserid & "'")) EmpFatrah = Nz(DLookup("fatrah", "tblEmpNames", "Emp_user='" & EmpUserid & "'"), 0) If mylevl = False Then Beep Me.LabelH.Caption = "خطأ!! .. الادخال غير صحيح" Me.TimerInterval = 3000 Me.id = "" Me.id.SetFocus Exit Sub End If ' Lookup empName once after confirming user existence empName = Nz(DLookup("Emp_Name", "tblEmpNames", "Emp_user='" & EmpUserid & "'"), "") strSql = "SELECT TOP 1 tblCheckINOut.id, tblCheckINOut.EmpUser, tblCheckINOut.chekInOut, tblCheckINOut.chkio, tblCheckINOut.ftra_id " & vbCrLf & _ "FROM tblCheckINOut " & vbCrLf & _ "WHERE (((tblCheckINOut.EmpUser)='" & EmpUserid & "')) " & vbCrLf & _ "ORDER BY tblCheckINOut.id DESC;" Set rs = CurrentDb.OpenRecordset(strSql) If rs.RecordCount = 0 Then rs.AddNew rs!EmpUser = EmpUserid rs!chekInOut = Now() rs!chkio = "I" rs!ftra_id = EmpFatrah Me.txtnm = empName Me.LabelH.Caption = "حضور" Me.Requery Me.TimerInterval = 3000 Me.id = "" Me.id.SetFocus rs.Update rs.Close Set rs = Nothing Exit Sub End If waitTime = Nz(DLookup("waitBtween", "tblTimeCtrl"), 0) AdTim = DateAdd("n", waitTime, rs!chekInOut) If Now() < AdTim Then Me.id.SetFocus Beep Me.LabelH.Caption = "توقيع مكرر !! انتظر قليلا ..." Me.id = "" Me.TimerInterval = 3000 Me.id.SetFocus rs.Close Set rs = Nothing Exit Sub Else If rs!chkio = "I" Then rs.AddNew rs!EmpUser = EmpUserid rs!chekInOut = Now() rs!chkio = "O" rs!ftra_id = EmpFatrah Me.txtnm = empName Me.LabelH.Caption = "انصراف" Me.Requery Me.id = "" Me.TimerInterval = 3000 Me.id.SetFocus rs.Update rs.Close Set rs = Nothing Exit Sub ElseIf rs!chkio = "O" Then rs.AddNew rs!EmpUser = EmpUserid rs!chekInOut = Now() rs!chkio = "I" rs!ftra_id = EmpFatrah Me.txtnm = empName Me.LabelH.Caption = "حضور" Me.Requery Me.TimerInterval = 3000 Me.id = "" Me.id.SetFocus rs.Update rs.Close Set rs = Nothing Exit Sub End If End If End Sub صحيح هو اضاف لي هذا المتغير : Dim EmpUserid As Variant ولكن هذا المتغير تم الاعلان عنه في الوحدة النمطية كمتغير عام وانا لا الومه لانه لا يعلم وليس له الا الظاهر ☺️

اختلفت الطريقة تماما ... التوقيع مفتوح .. ........وإن اردت ضوابط مستقبلا حاولنا صنع ذلك اضفت حقلا في جدول الموظفين يبين نوع حضوره : نظامي او مفتوح ( لم يتم التفعيل ) التقارير الآن على المفتوح الفرق بينهما هو : ان النظامي يكون الموظف ملتزما بالوقت الرسمي في الحضور والانصراف ويتم الاحتساب ما بين هذين الوقتين فقط اما المفتوح فالموظف مطالب بعدد ساعات محددة يتواجد فيها .. من غير اعتبار للتوقيت الرسمي ChkInOut_NetUp8.rar

اعرض الملف دليل شجرة حسابات لنشاط صناعي دليل شجرة حسابات لنشاط صناعي - حسب داتا ونظام برنامج سماك 6 صاحب الملف salahmosaed تمت الاضافه 29 نوف, 2022 الاقسام قسم الإكسيل  

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

السلام عليكم : من رخصة استاذنا المحترم Foksh وهذه مشاركة بسيطة تتضمن اربع ارقام يمكنك اختيار احدها 222.accdb

ممتاز

شكرا استاذة على التعدبل

وعليكم السلام نعم يمكنك فمثلا على افتراض ان هذا الحرف موجود بهذا النطاق (A2:H10) فستكون المعادلة كالتالى : =COUNTA(A2:H10)

تم التخلص من المديول ، ودمج الفكرة داخل نموذج البداية ، والذي اعتمدت في تصميمه على ما يلي :- ⏱️ جعلته يبدو كرسالة بمحتوى عربي بدلاً من الرسائل الإنجليزية والتي قد تربك المستخدم أو من كانت خبرته باللغة الإنجليزية ليست بالقوية . ⏱️ من خلال الكود أصبح بإمكان المبرمج اختيار البلد الذي يريد أن تكون له اللغة العربية في اللغة الإدارية ( Unicode ) . arabicSettings = GetArabicCountrySettings("Jo") ⏱️ من خلال التعديل الجديد عندما يفتح النموذج اذا كانت اللغة الإدارية تدعم العربية فسيتم اغلاق النموذج المرفق وفتح النموذج الخاص بالمشروع بك ( التعديل من الكود ) ⏱️ تم دعم بلدان الدول العربية ( كافة إلى حد ما وما استطعت من الحصول على LocalID الخاص بها .. ) الكود الكامل للنموذج بعد التحديث :- '********************************************** '*** *** '*** FFFFFF OOO KK KK SSSS HH HH *** '*** FF O O KK KK SS HH HH *** '*** FFFFF O O KKK SS HHHHHH *** '*** FF O O KK KK SS HH HH *** '*** FF OOO KK KK SSSSS HH HH *** '*** *** '********************************************** Option Compare Database Option Explicit #If VBA7 Then Private Declare PtrSafe Function GetUserDefaultUILanguage Lib "kernel32" () As Long Private Declare PtrSafe Function GetACP Lib "kernel32" () As Long #Else Private Declare Function GetUserDefaultUILanguage Lib "kernel32" () As Long Private Declare Function GetACP Lib "kernel32" () As Long #End If Private Type ArabicCountry LocaleName As String LocaleID As String CountryName As String countryCode As String End Type Private Const MSG_RESTART_SOON As String = "The computer will restart in 15 seconds" Private Const MSG_SAVE_FILES As String = "Please save all open files" Private Const MSG_CANT_RUN As String = "Your project cannot run without changing the system local to Arabic" Private arabicSettings As ArabicCountry Private Function IsArabicLanguage() As Boolean Dim CodePage As Long CodePage = GetACP() IsArabicLanguage = (CodePage = 1256) End Function Private Function GetArabicCountrySettings(ByVal countryCode As String) As ArabicCountry Select Case UCase(countryCode) Case "AE", "UAE", "EMIRATES" With GetArabicCountrySettings .LocaleName = "ar-AE" .LocaleID = "00003801" .CountryName = "United Arab Emirates" .countryCode = "971" End With Case "BH", "BAHRAIN" With GetArabicCountrySettings .LocaleName = "ar-BH" .LocaleID = "00003C01" .CountryName = "Bahrain" .countryCode = "973" End With Case "DZ", "ALGERIA" With GetArabicCountrySettings .LocaleName = "ar-DZ" .LocaleID = "00001401" .CountryName = "Algeria" .countryCode = "213" End With Case "EG", "EGYPT" With GetArabicCountrySettings .LocaleName = "ar-EG" .LocaleID = "00000C01" .CountryName = "Egypt" .countryCode = "20" End With Case "IQ", "IRAQ" With GetArabicCountrySettings .LocaleName = "ar-IQ" .LocaleID = "00000801" .CountryName = "Iraq" .countryCode = "964" End With Case "JO", "JORDAN" With GetArabicCountrySettings .LocaleName = "ar-JO" .LocaleID = "00000409" .CountryName = "Jordan" .countryCode = "962" End With Case "KW", "KUWAIT" With GetArabicCountrySettings .LocaleName = "ar-KW" .LocaleID = "00003401" .CountryName = "Kuwait" .countryCode = "965" End With Case "LB", "LEBANON" With GetArabicCountrySettings .LocaleName = "ar-LB" .LocaleID = "00003001" .CountryName = "Lebanon" .countryCode = "961" End With Case "LY", "LIBYA" With GetArabicCountrySettings .LocaleName = "ar-LY" .LocaleID = "00001001" .CountryName = "Libya" .countryCode = "218" End With Case "MA", "MOROCCO" With GetArabicCountrySettings .LocaleName = "ar-MA" .LocaleID = "00001801" .CountryName = "Morocco" .countryCode = "212" End With Case "OM", "OMAN" With GetArabicCountrySettings .LocaleName = "ar-OM" .LocaleID = "00002001" .CountryName = "Oman" .countryCode = "968" End With Case "QA", "QATAR" With GetArabicCountrySettings .LocaleName = "ar-QA" .LocaleID = "00004001" .CountryName = "Qatar" .countryCode = "974" End With Case "SA", "SAUDI" With GetArabicCountrySettings .LocaleName = "ar-SA" .LocaleID = "00000401" .CountryName = "Saudi Arabia" .countryCode = "966" End With Case "SD", "SUDAN" With GetArabicCountrySettings .LocaleName = "ar-SD" .LocaleID = "00002C01" .CountryName = "Sudan" .countryCode = "249" End With Case "SY", "SYRIA" With GetArabicCountrySettings .LocaleName = "ar-SY" .LocaleID = "00002801" .CountryName = "Syria" .countryCode = "963" End With Case "TN", "TUNISIA" With GetArabicCountrySettings .LocaleName = "ar-TN" .LocaleID = "00001C01" .CountryName = "Tunisia" .countryCode = "216" End With Case "YE", "YEMEN" With GetArabicCountrySettings .LocaleName = "ar-YE" .LocaleID = "00002401" .CountryName = "Yemen" .countryCode = "967" End With Case Else With GetArabicCountrySettings .LocaleName = "ar-SA" .LocaleID = "00000401" .CountryName = "Saudi Arabia" .countryCode = "966" End With End Select End Function Private Sub ChangeLanguage() On Error GoTo ErrorHandler Dim fso As Object Dim txtFile As Object Dim filePath As String filePath = Environ$("TEMP") & "\ChangeToArabic.bat" Set fso = CreateObject("Scripting.FileSystemObject") Set txtFile = fso.CreateTextFile(filePath, True) With txtFile .WriteLine "@echo off" .WriteLine "chcp 1256" .WriteLine "reg add ""HKLM\SYSTEM\CurrentControlSet\Control\Nls\Language"" /v Default /t REG_SZ /d " & arabicSettings.LocaleID & " /f" .WriteLine "reg add ""HKLM\SYSTEM\CurrentControlSet\Control\Nls\Language"" /v InstallLanguage /t REG_SZ /d " & arabicSettings.LocaleID & " /f" .WriteLine "reg add ""HKCU\Control Panel\International"" /v LocaleName /t REG_SZ /d " & arabicSettings.LocaleName & " /f" .WriteLine "reg add ""HKCU\Control Panel\International"" /v Locale /t REG_SZ /d " & arabicSettings.LocaleID & " /f" .WriteLine "reg add ""HKCU\Control Panel\International"" /v sLanguage /t REG_SZ /d ARA /f" .WriteLine "reg add ""HKCU\Control Panel\International"" /v sCountry /t REG_SZ /d " & arabicSettings.CountryName & " /f" .WriteLine "reg add ""HKCU\Control Panel\International"" /v iCountry /t REG_SZ /d " & arabicSettings.countryCode & " /f" .WriteLine "reg add ""HKLM\SYSTEM\CurrentControlSet\Control\Nls\CodePage"" /v ACP /t REG_SZ /d 1256 /f" .WriteLine "reg add ""HKLM\SYSTEM\CurrentControlSet\Control\Nls\CodePage"" /v OEMCP /t REG_SZ /d 1256 /f" .WriteLine "reg add ""HKLM\SYSTEM\CurrentControlSet\Control\Nls\CodePage"" /v MACCP /t REG_SZ /d 10004 /f" .WriteLine "reg add ""HKCU\Keyboard Layout\Preload"" /v 1 /t REG_SZ /d " & arabicSettings.LocaleID & " /f" .WriteLine "control.exe intl.cpl,, /f:""C:\Windows\System32\intl.cpl""" .WriteLine "timeout /t 5" .WriteLine "shutdown /r /t 15 /c ""سيتم إعادة تشغيل الجهاز بعد ( 15 ثانية ) لتطبيق إعدادات اللغة العربية"" /f" End With txtFile.Close Dim shellApp As Object Set shellApp = CreateObject("Shell.Application") shellApp.ShellExecute filePath, "", "", "runas", 0 ' MsgBox MSG_RESTART_SOON & vbCrLf & MSG_SAVE_FILES, vbInformation Exit Sub ErrorHandler: Resume Next End Sub Private Sub Btn_Yes_Click() If Not IsArabicLanguage() Then ChangeLanguage Else MsgBox "اللغة الإدارية الحالية في جهازك هي فعلاً اللغة العربية", vbInformation, arabicSettings.CountryName & " : اللغة العربية الحالية" End If End Sub Private Sub Btn_No_Click() MsgBox MSG_CANT_RUN, vbCritical DoCmd.Close acForm, Me.Name End Sub Private Sub Form_Load() arabicSettings = GetArabicCountrySettings("Jo") Txt_ConteryName.Value = arabicSettings.CountryName If IsArabicLanguage() Then DoCmd.Close acForm, Me.Name MsgBox "استبدل هذه الرسالة بكود فتح النموذج الرئيسي", , "عندما تكون اللغة = العربية" Else Btn_Yes.Visible = True Btn_No.Visible = True End If End Sub PALESTINE الملف المرفق مفتوح المصدر 👈 [ LanguageCheck V 2.0.accdb ]

بارك الله فيك استاذ ضاحى جعله الله في ميزان حسناتك يوم القيامه

بارك الله فيك استاذ مجدى وجزاك الله خير الثواب

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

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

وعليكم السلام-تفضل لك ما طلبت بهذه المعادلة =IFERROR(DGET($B$4:$G$12,B4,$C$17:$D$18),"") صفحة 1.xlsx

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

تفضل Suivi des Créances1.xlsx

طبعا لو هناك عدة شروط -بس كان عليك من البداية لعدم اهدار الوقت رفع الملف مدعوم بشرح كافى ووافى عن طلبك

فتح الله عليك وزادك الله من فضله

بارك الله فيك استاذ مجدى وزادك الله من فضله

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