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

screentogif اتفضل هذا هو رابط موقع البرنامج ورابط تحميل البرنامج https://screentogif.codeplex.com/ https://screentogif.codeplex.com/downloads/get/1554964 واسألك الدعاء للاستاذ الجليل jjafferr فهو من دلنى عليه

السلام عليكم ورحمة الله لست أدري إن كنت تأخرت في الرد، وهذه معادلة يمكن وضعها في الخلية B1 (أو غيرها) ثم سحبها إلى الأسفل... =IF(ROW($A1)<=COUNTA($A$1:$A$6);OFFSET($A$1;COUNTA($A$1:$A$6)-ROW($A1);;1);"") بن علية

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

اتفضل اخى واستاذى ياسر اليك حلا اخر {=INDEX($A$1:$A$6,LARGE(ROW($A$1:$A$6),ROW($A1)))}

الطريقة مجربة وسليمة 100% ويمكن اخفاء النموذج المسؤول ليعمل بصمت في الخلفية تصور انه يمكن ايضا ان يرسل لك رسائل sms يذكرك بمواعيدك

الموضوع : كود ترحيل البيانات بشكل مميز سأتناول أولا : شرح الكود حتى يسهل على الجميع أستخدامة داعيا الله ان يوفقنى الى ما يحبة ويرضة أ - سأقوم بدرب مثال يفضل ان تنفذة معى لكى تصل لكيفية عمل الكود وتطويعه لما تريد عملة أبدأ بفنح ملف أكسيل جديد : قم بتسمية ورقة العمل الاولى بأسم ادخال بيانات والورقة الثانية فواتير ثم فى صفحة العمل الاولى والتى تسمى بـ ادخال البيانات قوم بتصميم جدول كما هو موضح فى الصورة ثم تصميم زر فى نفس الصفحة حتى يصبح بنفس الشكل هذا لم لا يعرف كيفية تصميم زر يمكنة ذلك من خلال : ----------------------------------------------------- اصدار 2003 من مربع أدوات التحكم > ادارج زر ------------------------------------------------------ اصدار 2007 من المطور > ادراج زر ------------------------------------------------------- وفى الصفحة الثانية التى تم تسميتها باسم فواتير نصممها على هذا الشكل بعد تصميم تسمية الصفحتين والزر فى الصفحة الاولى يمكنك اضافة الكود من خلال اختيار وضع التصميم والضغط على الزر الذى سبق تصميمة دبل كليك ايسر على الماوس ثم نضع الكود التالى وسأقوم بشرحة تفصيليا كما بالصورة (الكود مرفق ) الجزء الاولى من الكود الجزء الثانى من الكود الجزء الثالث من الكود الجزء الرابع من الكود الجزء الخامس من الكود الجزء السادس والأخير ملاحظة : الكود يرحل بترتيب الادخال . لتحميل الشرح مصور + ملف المثال + الكود من هنا فى النهاية أسالكم الدعاء اذا افادكم ذلك

السلام عليكم ورحمة الله وبركاته وجدت هذه الدالة اثناء تجولي وحبيت ان اضع عليها مثال هنا لمن قد يبحث عنها الدالة هي FILELEN وهذا ببساطة شكل الدالة FileLen( file_path ) الدالة تحضر حجم الملف بالبايت .. وبإمكاننا التحويل الى ما نريد بعد ذلك هنا طرق التحويل المعروفة للجيمع . 1 Byte = 8 Bit 1 Kilobyte = 1,024 Bytes 1 Megabyte = 1,048,576 Bytes 1 Gigabyte = 1,073,741,824 Bytes 1 Terabyte = 1,099,511,627,776 Bytes في المرفق انا حولت الى كيلوبايت .. اترككم مع المثال .. فك الضغط على الدرايف D للتجربة وبعدها بإمكانك النقل الى اي مكان كل ما عليك هو معرفة المسار والإمتداد بالتوفيق للجميع fileSizeDemo.rar

السلام عليكم ورحمة الله وبركاته لدي نموذج يفتح مع بداية البرنامج وهو يحتوي على مواعيد محددة بالوقت لهذا اليوم سؤالي بالتحديد ... هل طريقتي بإستخدام هذا الكود صحيحه ولن تبسبب مشاكل للنظام لو فرضنا ان البرنامج يعمل طوال اليوم هذا هو الكود وفي المرفق توضيح اكثر Private Function sSA() On Error Resume Next Dim i, r As Integer Dim rs As Recordset Set rs = Me.RecordsetClone r = rs.RecordCount rs.MoveLast rs.MoveFirst For i = 1 To r If rs!mish_time = Time() Then DoCmd.OpenForm "alarm" End If rs.MoveNext Next rs.Close Set rs = Nothing End Function يتم استدعاء هذه الدالة عند حدث عداد الوقت كما هو موضح في النموذج frm_missions شكرا لكم AlartSysteM2003.rar

اشكرك كثيرا ً اخي العزيز لقد حلت المشكلة مع الشكرالجزيل وفقك الله وبارك الله فيك مع الشكرالجزيل

اخي ابو البراء اليك ما كنت أطلبه (أظن انه يوجد حلول اخرى) و ما زلت اطمع بالمزيد بدون تكرار مثلاً) Reverse_Without_Empty.rar

استاذي ياسر كلامك صحيح لكن الميزة انه لا يمكن مسحها او نسخها وايضات يمكن التعامل مع الشيت كانه غير محمي بكل الأحوال هي محاولة عسى ولعل

برايي افضل بهذا الراي لم يعد هناك حاجة او وجود ل اللوب !! الكود كافي بالعد كل ثانية واظهار الفورم ! بالتوفيق

كلامك صحيح واوافقك ! يمكن يصبح الكود هكذا Private Sub Form_Timer() If DCount("*", "tbl_MIssions", "mish_time=time() and mish_date=date()") > 0 Then DoCmd.OpenForm "alarm" clock.Caption = Time() End Sub تحياتي

السلام عليكم إليك مرفق فيه معادلة بسيطة مجرد اختيار الخلية التي بها المعادلة تبقى مخفية ولا يمكن تغيير محتواها انظر إلى محرر الأكود بالضغط على alt+F11 في sheet1 افتح view code هشام ابوسنى.rar

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

تفضل هذا مثال حسب طلبك بالنسبة للارقام التي من خلالها يتم التفريق بين المستخدمين كــ 22 ، 55 .... وغيرها فهذه يمكن لبرنامجك ان يضيفها آليا عند التسجيل حسب النوع تخصيص المداخل متغير.rar

لا حرمنا الله منك ولا من مشاركاتك جزاك الله خيرا أستاذ محمد أحبك الله الذى أحببتنا فيه

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

أخي الحبيب بن علية بارك الله فيك وجزيت خيراً على المعادلة الجميلة والرائعة .. أخي الغالي ابو يوسف جزيت خيراً على المشاركة الجميلة وإن كانت مكررة من قبل أخونا الحبيب أحمد الفلاحجي ولكنها مقبولة منك .. ربنا يبارك فيك ومشكور على المشاركة الرائعة أخي الحبيب أبو بسملة هوووووووووب جبت حلول كتير في المشاركة الأخيرة ليك وللأسف كلها مش مناسبة !! طبعاً معظمها شغال تمام التمام ..ولكن راعي أن تكون عملية البحث غير مقتصرة على النقل وفقط ..بل يجب أن يتم تجربة كل كود والتعديل عليه بما يتناسب مع الملف.. عايزين بحث وتدقيق وتفحيص وتمحيص .. وأعتقد إنك وصلت لي !! بالنسبة للملحوظة : السطر المشار إليه ليس بكود إنما معادلة توضع في الخلية B1 ثم يتم سحبها لأسفل

هذه مشاركة بطريقة اسهل قليلا للمتعلم drgat2.rar

اليوم والشهر بالهجرى تلقائى بالتوفيق اخوانى الاحباب التاريخ بالهجرى بشكل تلقائى.rar

تفضل أستاذى رمهان و جميع الإخوة المهتمين بالموضوع الحصول على الدرجة السابقة الدرجة رقم 2 ترتيبا فى جدول الدرجات حتى مع إضافة درجات جديدة للموظف وشكرا لجميع الإخوة خاصة الأستاذ رمهان mylasttry - 2.rar

وهذه بالاستعلام وبدوال المجال! SELECT tblDrgat.empId, DLookUp("[darganame]","tbldrgat","drgadate=#" & DMax("drgadate","tbldrgat","empid=" & [empid]) & "#") AS 1, DLookUp("[darganame]","tbldrgat","drgadate=#" & DMax("drgadate","tbldrgat","drgadate<#" & DMax("drgadate","tbldrgat"," empid=" & [empid]) & "# and empid=" & [empid]) & "#") AS 2 FROM tblDrgat GROUP BY tblDrgat.empId; وهناك افكار اخرى ! وهذه على جدول الموظفين SELECT جدول1.eid, جدول1.eName, DLookUp("[darganame]","tbldrgat","drgadate=#" & DMax("drgadate","tbldrgat","empid=" & [eid]) & "#") AS 1, DLookUp("[darganame]","tbldrgat","drgadate=#" & DMax("drgadate","tbldrgat","drgadate<#" & DMax("drgadate","tbldrgat"," empid=" & [eid]) & "# and empid=" & [eid]) & "#") AS 2 FROM جدول1;

انا لله وانا اليه راجعون البقاء لله اسال الله ان يلهمك الصبر وان يعوضك بذرية صالحه

عزيزي بعد التجربة لا يتم ضغط القاعدة الخلفية بقطع اخر اتصال ! لم يعتبره اغلاق للقاعدة ! اذا لابد من الفتح الصريح والاغلاق ! وهنا اعتبره افضل ..! لان الاتصال يحدث عند فتح كائن منضم لاحد الكائنات الخلفية وينقطع عند اغلاق الكائن ! فليس من الافضل يتم الضغط عند قطع الاتصال لانه يحدث كثيرا وليس فقط عند اغلاق القاعدة الامامية وهنا نستنتج انه لم يحدث مشاكل عند الاستاذ جعفر لانه لن يتم ضغط الخلفية الا بالفتح والاغلاق الصريح ! ولن يتم الا اذا لم يكون هناك اتصال بالقاعدة نهائيا هنا مارايك بالذهاب للقاعدة الخلفية ثم عمل ضغط واصلاح يدوي ؟ تحياتي

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

بسم الله الرحمن الرحيم اعضاء المنتدى الكرام السلام عليكم ورحمة الله وبركاتة اعلم انى مقصر معكم ولكن كانت ظروف طارئة وان شاء الله نعود اليكم بمجموعة منوعة من درووس الاكسيل انتظرونا وتابعونا درس اليوم بناء على سؤال احد الاصدقاء عن كيفية عمل فلتر او تصفية دون تغييير فى المسلسل للجدول فيديو شيق يارب يعجبكم https://youtu.be/kpRzecjmM0g

الله يبارك فيك وييسر امورك

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

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

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

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

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

السلام عليكم جرب هذا الشيئ في حدث الصفحة بعد حماية المعادلات واخفائها من اكسل Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Locked = True Then Me.Protect Password:="Secret" Else Me.Unprotect Password:="Secret" End If

السلام عليكم ورحمة الله وبركاته أخي الحبيب أحمد جربت الإضافة واشتغلت100% جزاكم الله خيراً

السلام عليكم ورحمة الله وبركاته أساتذتي الكرام ...أخي الحبيب أبو البراء جزاكم الله خيراً على ما تتفضلون به من أعمال تنهض بحركة الفكر العربي "البرمجي" أما بالنسبة لي فتحرك بي سرعة البحث عن فكرة لأطبقها وفقاً لما تطلبون أو تقترب منها عكس القيم : 1- نكتب القيم التي نريد في العمود A من A1:A6 2- ننسخها إلى العمود B من B1:B6 3- نكتب في موديول الكود التالي: Sub FlipColumns() Dim Rng As Range Dim WorkRng As Range Dim Arr As Variant Dim i As Integer, j As Integer, k As Integer On Error Resume Next xTitleId = "عكس القيم" Set WorkRng = Application.Selection Set WorkRng = Application.InputBox("المدى", xTitleId, WorkRng.Address, Type:=8) Arr = WorkRng.Formula For j = 1 To UBound(Arr, 2) k = UBound(Arr, 1) For i = 1 To UBound(Arr, 1) / 2 xTemp = Arr(i, j) Arr(i, j) = Arr(k, j) Arr(k, j) = xTemp k = k - 1 Next Next WorkRng.Formula = Arr End Sub 4- نضغط F5 أو Run من يطلب تحديد المدى وهنا من B$1:$b$6 $ ثم موافق فنحصل على النتيجة المقاربة لطلبكم الكريم. والسلام عليكم ورحمة الله وبركاته. عكس القيم.rar

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

جميل ومشكور بس انا عايز السجل الثاني فقط ! اي الدرجة الثانية فقط ؟

اعتقد هذا المرجع استاذ عبدالفتاح http://www.access-programmers.co.uk/forums/showthread.php?t=150368 لكن هل ممكن ترفع ملفك بعد التطبيق عليه بالتوفيق

ده ملف مشابه للطلب للاستفاده والافاده بالتوفيق Extracting-a-unique-sorted-list-based-on-frequency-of-occurrence.rar

وعليكم السلام أخي الكريم حراثي تفضل الكود Private Sub CommandButton1_Click() Range("B2").Value = TextBox1.Value Range("D3").Value = TextBox2.Value End Sub

بعد التجارب الامر requery فقط هو اختصار ل me.requery وللتجربة وضعت مربع قائمة فعند البحث لا تظهر النتائج بها لانها تحتاج ريكويري فاما تعمل ريكويري خاص بها او docmd.requery سيعمل للجميع فعند استخدام requery فقط لم تتحدث القائمة مما يظهر لنا انه نفس me.requery على غرار docmd.requery والذي قام بعمل ريكويري للكل تحياتي بحث واضافة-update.rar

ماشاء الله عليك ربنا يزيدك علم وإيمان وتقوى اجابة اكثر من رائعة ومفيدة بحق شكراً جزيلاً لك

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

أخي الحبيب عماد غازي مواضيعك مميزة ورائعة .. فقط ينقصها أن ترفق ملف في آخر الموضوع ليتمكن الأعضاء من التطبيق العملي تقبل تحياتي

السلام عليكم أستاذنا الكريم عماد غازي المحترم الذي يتحفنا بكل جديد ومفيد جزاكم الله خيراً على هذا العرض الرائع لهذه الدالة التي تبقي الأرقام متسلسلة في حالة التصفية أو وجود فراغات ولكن إن لم تكن نسخة الأوفيس من 2010 وما فوق فإنني سأعرض عمل دالة أخرى إثراء لما قلته وهي: SUBTOTAL =IF(B2<>"";SUBTOTAL(3;$B$2:B2);"") حيث تعطي النتيجة ذاتها تقريباً بعد الفلترة ...مع ملاحظة أن عيب هذه الدالة في السطر الأخير حيث لا تعطي كما هذه الدالة الجديدة AGGREGATE جزاكم الله خيراً والسلام عليكم ورحمة الله وبركاته.

وعليكم السلام بالنسبة للرقم ا: اعمل هذا الحدث للحقل m_sum ، في الحدث بعد التحديث: Private Sub m_sum_AfterUpdate() Me.m_sum = Me.m_sum - Me.com_name.Column(2) If Me.m_sum < Me.com_name.Column(2) Then MsgBox "القيمة اصغر" End If End Sub وبالنسبة للرقم 2: في الجدول notes ، في اعدادات الحقول (ما عدالرقم التلقائي) ، اجعل "مطلوب" = نعم: جعفر 322.db.accdb.zip

حياك الله اخي الكريم البرامج كثيرة ... او بالمعنى الأصح لغات البرمجه كثيرة ... ولكنها تصنف لغة برمجة ويب .. مثل Python .. asp.net والكثير من لغات برمجة الويب طبعا هذا اذا كنت تحتاجها على الانترنت لان الموقع المعروض يبدو على شبكة الانترنت ... اذا كنت تريد البرنامج على سطح المكتب فلغات البرمجة ايضا كثيرة ومنها الــ vba مع قواعد بيانات الأكسس الذي انت في جنباته الآن .. بالتوفيق

الأدوات المهمة ووظائفها الخصائص الشائعة للأدوات نظرا لاهتمام بعض الاعضاء الذين لم يتعاملو مع واجهات البرمجة عموما سواء VBA or VB6 والاستفسارات الدائمة عن بدايات التعامل مع الفيجوال قمت بتوضيح الامور اكثر قليلا وكما قال احد الاخوة لي محتاجين نبدأ من تحت الصفر بداية هذه قائمة الادوات الموجودة علي يسار البرنامج خصائص الأدوات الشائعة الاستخدام الخصائص الشائعة: هناك مجموعة من الخصائص الشائعة الاستخدام والمتوفرة لمعظم الأدوات، سنقوم الآن بشرح أهم هذه الخصائص وسنؤجل الحديث عن باقي الخصائص فيما بعد. 1- الخاصية Name: تعتبر هذه الخاصية من أهم الخصائص على الإطلاق، وهي متوفرة لجميع الأدوات دون استثناء، وهذه الخاصية تحدد الاسم البرمجي للأداة، وهو الاسم الذي يستخدم عند كتابة شفرة تخص هذه الأداة مثل : Form1.Caption="Yasser" حيث Form1 تمثل اسم النافذة. عندما تضع أداة جديدة أو تضيف نافذة جديدة يتم وضع الخاصية Name افتراضياً لهذه الأداة وذلك بذكر اسم الأداة يليها رقم مثل Form1 و Form2 و Label1 و Label2 إلى آخره. والآن إذا كنت ترغب في تغيير هذا الاسم الافتراضي فعليك تذكر ما يلي: 1- يجب أن يبدأ الاسم بحرف ولا يجوز أن يبدأ برقم، ويجوز أن يتخلله أرقام. 2- يفضل أن يكون الاسم باللغة الإنجليزية، وذلك لتجنب المشاكل التي يمكن أن تحدث عند استخدام الأسماء العربية ( أتمنى قريبا يقال العكس) 3- يجب أن لا يتجاوز الاسم 40 حرفاً. 4- لا يجوز استخدام بعض المحارف مثل النقطة و الفراغ و الفاصلة و … 5- لا يجوز استخدام الكلمات المحجوزة مثل : FOR و WHILE و FUNCTION و … 6- يفضل استخدام الأسماء التي تدل على وظيفة الأداة، وتجنب الأسماء العشوائية. مثلاً: يمكنك تسيمة النافذة "F" بدلاً من "Form1" و لكن عندها ستصبح الشفرة على الشكل: F.Caption="Yasser" الخاصية Name متوفرة أثناء التصميم فقط، أي من المستحيل تغيير الخاصية Name ضمن الشيفرة وهناك العديد من الخصائص الأخرى تشترك معها بهذه الصفة. 2- الخاصية BackColor (لون الخلفيه): تحدد هذه الخاصية لون أرضية الأداة، وعند محاولة تغيير هذه الخاصية يظهر مربع صغير يحوي سهم ، عند الضغط على هذا المربع يظهر لوح الألوان الذي يمكننا من اختيار اللون الذي نريد . ونلاحظ في مربع الألوان وجود بوابتين الأولى Palette ومنها نختار ألوان ثابتة ، والثانية System ومنها نختار ألوان يستخدمها النظام Windows . 3- الخاصية Caption (العنوان): وهي تحدد النص الذي سيظهر على الأداة كعنوان لها، ويجب أن لا يتجاوز النص 255 حرفاً بما في ذلك الفراغات. 4- الخاصية Enabled (التمكين): تحدد هذه الخاصية فيما إذا كانت الأداة ستتأثر بالأحداث (النقر أو حركة الماوس) أم لا، حيث تأخذ القيمتين True تتأثر أو False لا تتأثر. لن يظهر تأثير هذه الخاصية إلا بعد تنفيذ البرنامج. 5- الخاصية Font (الخط): تستخدم من أجل تحديد شكل ونوع وحجم الخط الذي سيظهر به عنوان الأداة. 6- الخاصية ForeColor (لون الخط): وهي تحدد لون الخط الذي سيكتب به عنوان الأداة. 7- الخاصية Height: تحدد ارتفاع الأداة . 8- الخاصية Width: تحدد عرض الأداة. 9- الخاصية Left: تحدد مقدار بعد الطرف الأيسر للأداة عن الطرف الأيسر للنافذة. 10- الخاصية Top: تحدد مقدار بعد الطرف العلوي للأداة عن الطرف العلوي للنافذة. 11- خاصية Picture: وتستخدم لتحميل صورة ووضعها كخلفية للأداة. 12- خاصية Visible: وتستخدم لإظهار أو إخفاء الأداة أثناء التنفيذ. من المهم الآن أن تقوم بإضافة الأدوات وتجريب الخصائص السابقة، وتصميم واجهات مختلفة تتخيلها.

السلام عليكم يا سلام عليك أخي خضر الرجبي .. فينك من زمان . الحقيقة أنا أكره كثرة المديولات في البرنامج وخصوصا أكواد API . الدالة بشكلها الأخير وبدون موديول الـ API . Function GetSysHijri(ByVal HijriDate As Variant, _ Optional ByVal FormatPic As String = "dd/mm/yyyy") As String Dim oKey As Variant Dim AddDays As Integer Dim CurrCal As Byte Dim NewDate As String Dim ddd As String Dim dddd As String Dim Pos As Integer On Error Resume Next CurrCal = Calendar Calendar = vbCalHijri HijriDate = CDate(HijriDate) If Not IsDate(HijriDate) Then Exit Function If Year(HijriDate) = Year(Date) And _ Month(HijriDate) = Month(Date) Then Set oKey = CreateObject("Wscript.Shell") Select Case oKey.RegRead("HKEY_CURRENT_USER\control Panel\International\AddHijriDate") Case "AddHijriDate-2": AddDays = -2 Case "AddHijriDate": AddDays = -1 Case "": AddDays = 0 Case "AddHijriDate+1": AddDays = 1 Case "AddHijriDate+2": AddDays = 2 End Select Set oKey = Nothing Else AddDays = 0 End If ddd = format(HijriDate + AddDays, "ddd") dddd = format(HijriDate + AddDays, "dddd") NewDate = format(HijriDate + AddDays, FormatPic) If ddd <> format(HijriDate, "ddd") Then Do While True If NewDate Like "*" & dddd & "*" Then Pos = InStr(1, NewDate, dddd) NewDate = Left(NewDate, Pos - 1) & _ format(HijriDate, "dddd") & _ Mid(NewDate, Pos + Len(dddd)) ElseIf NewDate Like "*" & ddd & "*" Then Pos = InStr(1, NewDate, ddd) NewDate = Left(NewDate, Pos - 1) & _ format(HijriDate, "ddd") & _ Mid(NewDate, Pos + Len(ddd)) Else Exit Do End If Loop End If GetSysHijri = NewDate Calendar = CurrCal End Function تحياتي . SysHijriDate.rar