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

السلام عليكم , الاخوة الكرام كل عام وانتم بخير بمناسبة شهر رمضان وعيد الفطر المبارك اعادهم الله علينا بالخير والبركة موضوعنا اليوم بعد غياب كما بالعنوان كيف تنفذ شاشة متطورة حتى النتيجة بالمثال افتح فورم جديد ثم قم بعمل 2 Rectangle فى الجانب والاعلى , الجانب للقائمة والاعلى كشريط للعنوان , بالنسبة للون الخلفية الخاصة بهم يمكنك عمل اللون الذى تفضله , بالنسبة للون المثال هو لون قوائم Microsoft Outlook قمت بسحبه وتطبيقه هنا , السؤال كيف تسحب لون تريده ولا تعرف درجته بالضبط ؟ يمكنك تطبيق هذه الفكرة الجديدة , هناك اداة يستخدمها مطورين الويب و المصممين لسحب الألوان بدرجاتها بدقة عالية وهذه الأداة اسمها Just color picker انظر لشكلها وللصورة قم بتنزيلها من الموقع الرسمى من هنا https://annystudio.com/software/colorpicker/ وصورتها قم بفتح الاداة وقم بالاشارة على أى لون تريده ثم اضغط على Alt+x لحفظ درجة اللون بالطريقة التى تحبها HTML او RGB وفى المثال سنستخدم الطريقتين , بالنسبة للHTML يمكنك سحب اللون بالاداة واضغط على Copy Value مع التأشير على HTML كما بالصورة قم بنسخ القيمة وفى الاكسس فى الخصائص الخاصة بأى عنصر ستجد Back Color قم باضافة رمز # قبل درجة اللون من الاداة وضعها فى الاكسس وستجد ان اللون تم تطبيقه وبالتالى قمت بأخذ لونك المفضل ويمكنك محاكاة اى تصميم لاى برنامج تحبه . ننتقل للتصميم بداية التصميم من فكرتى وتطبيقى واكوادى من البداية اللى النهاية وأتمنى دعوة بظهر الغيب بصلاح الحال , فى التصميم ستجد ان عند تحديد زر من ازرار القائمة ستقوم الايقونة بالتحرك والخط يختلف و تصبح ايقونة الزر هى الايقونة الرئيسية بالأعلى , لعمل ذلك قم بفتح الفاجيوال بيزيك وضع الاكواد التالية : Sub ReFormat(Sender As CommandButton) Me.PictureBox.Picture = Sender.Picture Me.lbl.Caption = Sender.Caption Sender.PictureCaptionArrangement = acRight Sender.FontUnderline = True End Sub شرح الكود :: المطلوب معرفة اولا الزر الذى تم ضغطه ولذلك قمت بعمل الكود السابق مع التحكم فى الزر الذى تم ضغطه كمحازاة النص والايقونة وهكذا , يمكنك زيادة حجم الخط او أي تنسيق تريده. يتم استدعاء الكود بالشكل التالى من أى زر امر : ReFormat ActiveControl تمام , طيب فى هذه الحالة التنسيق سيستمر اذا ضغطت على زر آخر وستظل الايقونة والخط بالتنسيق الذى قام الكود السابق بعمله , وبالتالى محتاجين نلغى ما قام به الكود السابق عن كل الازرار الا الزر الحالى سيحتفظ بالتنسيق الجديد . عملت الكود التالى Sub Restore() Dim ctrl As Control For Each ctrl In Me.Controls If TypeName(ctrl) = "CommandButton" Then If ctrl.Name <> ActiveControl.Name Then ctrl.PictureCaptionArrangement = acLeft ctrl.FontUnderline = False End If End If Next End Sub شرح الكود :: يقوم بالمرور على كل عناصر التحكم واذا وجدها زر سيقارن اسمها مع اسم الزر الحالى فى حالة اختلافهما يقوم بارجاع التنسيق الاصلى للزر قبل تطبيق كود التنسيق عليه , وبالتالى مع كل زر امر سيتم وضع الكود التالى Restore ReFormat ActiveControl ستجد ان هناك خط يتغير لونه مع كل ضغطة زر , هنا سنستخدم طريقة الالوان الاخرى RGB قم بسحب اللون الذى تريده بالاداة وقم بوضع اللون مثل المثال التالى : Me.Line51.BorderColor = RGB(35, 204, 183) حيث ان قيمة اللون بين الاقواس الاحمر,الاخضر,الازرق RGB . باقى TabControl متعدد الصفحات قم بانشاءه ولا تنسى بعد الانتهاء منه تحديد Style = None الخطوة الاخيرة الانتقال الى صفحات هذا الTabControl عن طريق الكود وهناك طريقتين : اذا اردت تحديد الصفحة المطلوبة والوقوف عليها يمكنك استخدام : Me.MyTabs.Pages(0).SetFocus حيث ان 0 هو رقم Index او ترتيب الصفحة فى المستعرض , وستجد عند فتح النموذج ان الصفحة 0 يتم فتحها وعند الضغط ايضاً على ايقونة المنزل سينتقل اليها . اذا اردت فتح الصفحة بدون الوقوف فيها يمكنك استخدام : Me.MyTabs.Value = 0 وستجد الطريقتين فى المثال المرفق . لا تنسى ضبط خاصية Anchor لتثبيت العناصر او مدها مع تكبير او تصغير النموذج كما فى المثال . اعتذر عن الشرح قليل التفاصيل الى حد ما ولكنى معتمد على خبرتكم . مرفق مثال به كل ما تم شرحه , دمتم بخير ستجد المثال فى اول مشاركة لأن المنتدى لم يسمح لى ان تتعدى المرفقات 4.8 ميجا . المثال مرفق Modern UI Access - Amr Ashraf.accdb قمت باضافة صغيرة لم تظهر فى الصورة المتحركة لأنها سجلت مسبقاً , عند الضغط على صورة المنزل ستعود كافة الايقونات الى مكانها الطبيعى .

اتفضل اخى @محمد احمد لطفى حاجه على قدى واكمل باقى الوحده وان شاء الله اخوانا واساتذتنا يقدموا ما لديهم Function cheekDate(sDate As Date, eDate As Date, x As Integer) If sDate = #1/1/1990# And eDate = #9/6/2016# And x = 1 Then cheekDate = DateDiff("ww", #1/1/2016#, #9/6/2016#) ElseIf sDate = #9/7/2016# And eDate = #9/30/2020# And x = 2 Then cheekDate = DateDiff("m", #9/7/2016#, #9/30/2020#) ElseIf sDate >= #9/30/2020# And x = 2 Then cheekDate = DateDiff("m", #10/1/2020#, Date) End If End Function بالتوفيق ضريبة _1.mdb

زي ماتوقعت هل التاريخ ثابت ام متغير في اعتقادي تصوير المطلوب على شيت اكسل يسهل من الفهم والحل اخي العزيز

حل متواضع بالمعادلات بحسب ما فهمت جلب البيانات على ختيار رؤوس الاعمده 001.xlsm

لكي تعم الفائدة حل للاستاذ ياسر

معادلة ترحيل يعمل مع أي اصدار test001.xlsm

أو هنا :

السلام عليكم أخي محمد .. أطلع على هذا الموضوع .. لعلك تجد فيه حاجتك :

بعد اذن اخي @احمد الفلاحجي اذا كانت تسمية الزر = نعم ... سيقوم بتشغيل استعلام التحديث ويجعل قيمة done=True وهذا استعلام التحديث في وضع التصميم واذا كانت تسمية الزر = لا ... سيقوم بتشغيل استعلام التحديث ويجعل قيمة done=False

وعليكم السلام -نعم يمكن ذلك بهذا الكود Sub Splitbook() Dim xPath As String xPath = Application.ActiveWorkbook.Path Application.ScreenUpdating = False Application.DisplayAlerts = False For Each xWs In ThisWorkbook.Sheets xWs.Copy Application.ActiveWorkbook.SaveAs Filename:=xPath & "\" & xWs.Name & ".xlsx" Application.ActiveWorkbook.Close False Next Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub أو كان عليك من البداية استخدام خاصية البحث بالمنتدى قبل طرح مشاركتك فبها طلبك كيفية فصل الشيتات الموجودة داخل الملف إلى ملفات منفصلة الملف به اربع صفحات.xlsm

بسم الله الرحمن الرحيم السلام عليكم ورحمة الله وبركاته يسرني اليوم أن أقدم لكم هذه الهدية الرمضانية المتميزة والرائعة 😊 ( الكاتب الذكي لدوال المجال في أكسس ) Dloockup, DCount, DMax, DMin, Dfirst, DLast , DSum, DAvg هذه الأسطورة هي عبارة عن أداة صممتها في أكسس ( بفضل الله وحمده ) تقوم بكتابة دوال المجال نيابة عنك بشكل آلي .. وتعطيك النتيجة بشكل مباشر 😉👌🏼 لن يخطيء أحد بعد اليوم في كتابة جملة هذه الدوال إن شاء الله 😁 كل ما عليك فعله هو استيراد هذه الأداة لبرنامجك ثم اختيار الجدول أو الاستعلام المطلوب والحقل المراد وبعدها سترى العجب العجاب 🙂 ✨ ومن مزاياها :✨ 1 - تسهل عليك كتابة أسماء الجداول والحقول ( فقط تختارها من القائمة المنسدلة ) . 2- يحل مشكلة تداخل النصوص عند استخدامها مع الجداول والحقول المكتوبة باللغة العربية . 3- تفحص لك النتيجة مباشرة للتأكد من أنك ستحصل على البيانات التي تريدها . 4 - سهلة الاستخدام فقط اتبع الخطوات الموضحة وتأكد من اختيار نوع البيانات الصحيح . 5 - يمكنك عمل دالة بأربعة 4 معايير بكل سهولة ويسر . 6 - يمكنك عمل تعديلاتك الخاصة على الدالة مباشرة وفحص النتيجة مباشرة بعد التعديل على النتيجة النهائية . 7 - إمكانية الحصول على الصيغة الخاصة بمحرر الأكواد VBA أو الصيغة المستخدمة في الاستعلامات ومنشيء التعبير . 8- إمكانية استخدام الأداة بشكل مستقل من غير الحاجة لنقلها إلى برنامجك . 9- وغيرها الكثير مما سيفتح الله عليكم اكتشافه بأنفسكم إن شاء الله 😅 طريقة الاستخدام : سهلة يسيرة بحمد الله .. فقط قم بسحب النموذج المسمى SmartDomainFunctionsBuilder_F إلى برنامجك عن طريق السحب والإفلات .. ثم قم بفتح النموذج عندك وسوف يقوم هو آليا بالتعرف على الجداول والاستعلامات الخاصة ببرنامجك بدون الحاجة إلى جهد يذكر 🙂 ( مع إمكانية استخدام الأداة بشكل مستقل من غير الحاجة لنقلها لبرنامجك ولكنك ستفقد الكثير من المميزات 😉 ) الأداة تم عمل الكثير من التجارب عليها وتم تلافي العديد من الأخطاء وإصلاحها بحمد الله وفضله... ولكن لا زلت لا أستغني عن آراءكم وملاحظاتكم من خلال استخدامكم لها 😉 الشرح بالتفصيل : 🙂 وهنا قمت بشرح الأداة بشكل مفصل نوعا ما في مقطع فيديو مدته نصف ساعة تقريبا : وأخيرا التحميل 😊 تحميل الملف الأصلي : >> حمل من هنا آخر إصدار للأداة << تحميل الملف بلمسات المهندس العزيز @د.كاف يار : د.كاف يار __Domain Functions Builder V1.0.accdb وأهم من الأداة نفسها 😉 لا تنسوني من صالح دعائكم لي ولوالدي .. ولا تحرموني من آرائكم ومقترحاتكم ونصحكم وإرشادكم 🙂 أخوكم ومحبكم موسى الكلباني 😊 ‏‏Domain Functions Builder V1.0.accdb

السلام عليكم سوف نشرح في هذا الموضوع طريقة سهلة جدا لإضافة QR CODE للتقرير داخل مربع نص و يدعم اللغة العربية كذلك أولا: هناك ملف تنفيذي يقوم بتسجيل الأدوات و نوع الخط نقوم بتثبيته داخل الكمبيوتر ثانيا: لإضافة QR CODE نقوم باستدعاء الوحدة النمطية الموجودة في المرفق في مصدر عنصر التحكم لمربع النص و نغير نوع الخط إلى BCW_2D =QrCode([T];1;1;صواب;4;1) [T]: هو مربع نص نأخذ منه البيانات و هذا رابط المصدر : https://barcodewiz.com/user-manual/qr-code-fonts/create_qr_code_barcodes_in_ms_access.aspx و أخيرا تمتع بـQR CODE رائع أرجوا من الإخوة تجربته و موافاتنا بالنتائج. توليد QR CODE.rar

السلام عليكم ورحمة الله تعالى وبركاته الشرح الاتى لا يخص الأكسس بصفة خاصة ولكن لحماية حذف القاعدة او اى ملف داخل مجلد او المجلد الذى يحتوى قاعدة البيانات بالخطأ اولا نقوم بعمل مجلد جديد ونعطيه الاسم الذى نريد على سبيل المثال نضع مجلد جديد داخل القطاع D ونعطى المجلد اسم BackDB نقوم بتحديد المسار ونقوم بنسخه فيكون D:\Test\BackDB ولو كان اسم المجلد من مقطعين مثل Back DB سوف يكون المسار نسخ المسار الى ملف نصى ونقوم بتعديله ليكون D:\Test\Back_DB بعد ذلك نقوم بفتح موجه الاومر DOS ونقوم بكتابة او لصق الامر الاتى cacls D:\Test\BackDB /P everyone:n ولو اسم المجلد من مقطعين يكون cacls D:\Test\Back_DB /P everyone:n ثم نضغط على المقتاح Enter من لوحة المقاتيح ثم نضغط على المفتاح Y من لوحة المفاتيح كما هو موضح فى الصورة بعد ذلك نغلق موجه الاوامر DOS ونذهب الى المجلد ونقوم بالضغط عليه كليك يمين ونختار Properties تظهر لنا النافذة الاتية نحدد التبويب Security ثم نضغط بعد ذلك على Advanced كما هو موضع بالصورة ثم بعد ذلك تظهر لنا النافذة الاتية نقوم بالتحديد اولا كما هو فى الخطوة رقم 1 بالصورة ثم بعد ذلك كما هو بالخطوة رقم 2 نقوم بالضغط على Edit ثم بعد ذلك تظهر لنا النافذة الاتية نقوم بالضعط على Show Advanced Permissions ثم بعد ذلك تظهر لنا النافذة الاتية 1- فى الـ Type نختار Allow 2- فى اختيارات الـ Permissions نقوم بإزالة التأشير من على الاتى Delete Delete Subfolders and files لتصبح الاعدادت كما بالشكل الاتى ثم نضغط OK الان انسخ قاعدة البيانات داخل المجلد او اى ملفات تخاف من فقدانها جرب حذف الملفات لن يتم حذفها حاول حذف القاعدة كذلك لن يتم حذفها كذلك اقتح القاعدة واضف اليها بيانات او عدل او احذف منها اى بيانات سوف تعمل القاعدة بشكل طبيعى جدا لو اردت حذف المجلد او اى شئ بداخلة فقط استخدم الامر الاتى فى موجه اوامر الـ DOS cacls D:\Test\BackDB /P everyone:f وبعد حذف ما تريد يمكنك اعادة الخطوات ان اردت ارجاع الحماية مرة اخرى انتهى الشرح دمتم فى امان الله...

شاهد المرفق اخي xl.rar

منور اخى ومهندسنا العزيز @Eng.Qassim اخى محمد فى تعديل بسيط للشرط الاخير Function cheekDate(sDate As Date, eDate As Date, x As Byte) If sDate >= #1/1/1990# And eDate <= #9/6/2016# And x = 1 Then cheekDate = DateDiff("ww", sDate, eDate) ElseIf sDate >= #9/7/2016# And eDate <= #9/30/2020# And x = 2 Then cheekDate = DateDiff("m", sDate, eDate) ElseIf sDate >= #9/30/2020# And sDate <= Date And x = 3 Then cheekDate = DateDiff("m", sDate, eDate) End If End Function

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

ربنا يبشرك بكل خير ان شاء الله اتفضل وقمت بعمل تعديل بسيط عليها ايضا Function cheekDate(sDate As Date, eDate As Date, x As Byte) If sDate >= #1/1/1990# And eDate <= #9/6/2016# And x = 1 Then cheekDate = DateDiff("ww", #1/1/2016#, #9/6/2016#) ElseIf sDate >= #9/7/2016# And eDate <= #9/30/2020# And x = 2 Then cheekDate = DateDiff("m", #9/7/2016#, #9/30/2020#) ElseIf sDate >= #9/30/2020# And x = 3 Then cheekDate = DateDiff("m", #10/1/2020#, Date) End If End Function بالتوفيق ضريبة _2.mdb

انظر للمرفق..لقد استغنيت عن جدول التصنيف Database32.accdb

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

بارك الله فيك استاذي هذا كله بفضل تعليم اساتذتى فى المنتدي بارك الله فيهم وحفظهم من كل سوء وما ارانا الله فيهم شر وبارك الله لهم فى عافيتهم ومالهم وعلمهم

الشكر لله ثم لاخواننا واساتذتنا جزاهم الله عنا كل خير بلاش استاذ فما انا سوى طالب علم اتعلم معكم اخوانى بارك الله فيكم برجاء مراجعه النتائج التى ارفقتها لك بالمشاؤكه السابقه مع نتائجك واخبرنى ايهما اصح وان شاء الله يشاركنا اخواننا واساتذتنا جزاهم الله عنا كل خير بالتوفيق

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

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

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

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

الملف المرفق لاحد الاعضاء يوجد به أكواد للترحيل والاستدعاء يمكننك الاستفادة منه في موضوعك كود ترحيل واستدعاء.xlsm

وعليكم السلام-تفضل تم عمل قائمة منسدلة بأرقام الجلوس وبناءاً على اختيارك منها سيتم جلب بيانات الشهادات شهادات ,والراسبين 4 تعريق 1متغيرات.xlsm

جزيت عنى خير الجزاء

اذا كان ما تريد هو حساب العمر بين تاريخين اليك هذا النتيجه (مرفق معها مديول "داله حسابيه ") Function fAge(dteStart As Variant, dteEnd As Variant) As Variant '******************************************* 'Purpose: Accurately return the difference ' between two dates, expressed as ' years.months.days 'Coded by: raskew (from MS Access forum) 'Inputs: From debug (immediate) window ' 1) ? fAge(#12/1/1950#, #8/31/2006#) 'Calculate btw 2 specific dates ' 2) ? fAge(#12/30/2005#, Date()) ' Calculate as of today's date '******************************************* Dim intHold As Integer Dim dayhold As Integer 'correctly return number of whole months difference 'the (Day(dteEnd) < Day(dteStart)) is a Boolean statement 'that returns -1 if true, 0 if false intHold = DateDiff("m", dteStart, dteEnd) + (Day(dteEnd) < Day(dteStart)) 'correctly return number of days difference If Day(dteEnd) < Day(dteStart) Then dayhold = DateDiff("d", dteStart, DateSerial(Year(dteStart), Month(dteStart) + 1, 0)) + Day(dteEnd) Else dayhold = Day(dteEnd) - Day(dteStart) End If fAge = LTrim(Str(intHold \ 12)) & " years " & LTrim(Str(intHold Mod 12)) & " months " & LTrim(Str(dayhold)) & " days" End Function ضريبة (1).mdb

بعتذر لحضرتك انا مش قادر افهم ما تريد هل تريد ان يتم الحساب كانه مثلا كحساب الاعمار ؟

ضريبة (1).mdb

DateDiff("ww";[txtDate1];[txtDate2]) لكن افضل ان تكون DateDiff("d";[txtDate1];[txtDate2])/7 لا فى الدالة الاولى اذا كان الفتره بين التاريخين هم 4 اسابيع ويومين كمثل فانه يحسبه 5 اسابيع DateDiff("m";[txtDate1];[txtDate2])

الشكر لله ثم لاخواننا واساتذتنا جزاهم الله عنا كل خير وانت طيب بالتوفيق

السلام عليكم وهذه مشاركتي مع الاخوة والاساتذة بالتوفيق فرز (3).accdb

السلام عليكم ورحمه الله وبركاته مشاركه مع اخوانى واساتذتى الافاضل جزاهم الله عنا كل خير اخى @nabilalibibo جرب التعديل التالى Like [Forms]![frm_Search]![Ser_Grade] & "*" بالتوفيق فرز_1.accdb

اخي بسبب تغير اسماء الحقول الاتوفلتر في الملف السابق لا بعمل ..وتم التعديل ..شاهد المرفق كود (1).xlsb

وجزاكم مثله اخى الكريم الحمد لله الذي بنعمته تتم الصالحات

وعليكم السلام اخى @محمد عدنان طلبك من البدايه كان ترحيل صف واحد وهو في الخليه b4 من شيت data وهذا ما تم عمله اختر افضل اجابه لسؤالك وافتح موضوع جديد بالطلب الجديد وان شاء الله تجد مطلبك سواء منى او من الاساتذه

كنت أريد أن أقوم بإخفاء شاشة الاكسيس ، فقمت بالبحث فى المنتديات الاجنبية و وجدت هذة الطريقة و جربتها و كانت سليمة 100 % و نبدأ بالخطوات : 1 - نسخ هذا الكود و لصقة فى module و نسمية باى اسم فهذا لا يهم Private Declare Function IsWindowVisible Lib "user32" (ByVal hwnd As Long) As Long Dim dwReturn As Long Const SW_HIDE = 0 Const SW_SHOWNORMAL = 1 Const SW_SHOWMINIMIZED = 2 Const SW_SHOWMAXIMIZED = 3 Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, _ ByVal nCmdShow As Long) As Long Public Function fAccessWindow(Optional Procedure As String, Optional SwitchStatus As Boolean, Optional StatusCheck As Boolean) As Boolean If Procedure = "Hide" Then dwReturn = ShowWindow(Application.hWndAccessApp, SW_HIDE) End If If Procedure = "Show" Then dwReturn = ShowWindow(Application.hWndAccessApp, SW_SHOWMAXIMIZED) End If If Procedure = "Minimize" Then dwReturn = ShowWindow(Application.hWndAccessApp, SW_SHOWMINIMIZED) End If If SwitchStatus = True Then If IsWindowVisible(hWndAccessApp) = 1 Then dwReturn = ShowWindow(Application.hWndAccessApp, SW_HIDE) Else dwReturn = ShowWindow(Application.hWndAccessApp, SW_SHOWMAXIMIZED) End If End If If StatusCheck = True Then If IsWindowVisible(hWndAccessApp) = 0 Then fAccessWindow = False End If If IsWindowVisible(hWndAccessApp) = 1 Then fAccessWindow = True End If End If End Function ---------------------- 2- قم بعمل ماكرو أسمة mcrHide ضع بة اكشن run code و فى خانة Function ضع الكود التالى fAccessWindow ("Minimize", False, False) ------------------------------ 3 - قم بعمل ماكرو أخر أسمة mcrRestore ضع بة نفس الاكشن السابق run code و فى خانة Function ضع الكود التالى fAccessWindow ("Show", False, False) ------------------------------- 4 - الأن الخطوة الاكثر مللاً إذا كانت لديك العديد من النماذج قم بتغيير خصائص كل النماذج : popup قم بتحويلها إلى yes بدلاً من no ------------------------------- 5- فى النموذج الرئيسى الذى تريدة ان يبدأ بالفتح ضع الكود التالى : Private Sub Form_Open(Cancel As Integer) DoCmd.RunMacro "mcrHide" End Sub ----------------------------- 6 - فى كل التقارير ضع الكود التالى عند الحدث OnOpen DoCmd.RunMacro "mcrRestore" و عند الحدث OnClose DoCmd.RunMacro "mcrHide" ------------------------------- و بهذا تكون قد إنتهت الخطوات ربما تظهر انها خطوات طويلة ، لكنها طريقة فعالة جداً و تعطى منظر إحترافى جميل للبرنامج و اعتذر للإطالة و تحياتى للجميع New_Microsoft_Access_Application.rar

وعليكم السلام 🙂 هذا سطر حفظ الملف (انا اعطيت صورة كل نوع من الباركود اسم مختلف) ، واسم الصورة هنا QR_code.png : Output_File = Chr(34) & Application.CurrentProject.Path & "\Data\QR_images\" & "QR_code.png" & Chr(34) اذا اردت حفظ الصورة برقم ID الموظف ، سيكون الكود: Output_File = Chr(34) & Application.CurrentProject.Path & "\Data\QR_images\" & Me.ID & Chr(34) بس مثل ما انا قلت في البداية ، واقعا ما تحتاج الى صورة لكل موظف ، لأنك تحتاج تطبع الهوية والسلام ، فمافي داعي لحفظ الصورة ، وخصوصا اذا عملت تغيير في البيانات ، فالصورة القديمة لن تنفعك ، بينما طباعة هوية جديدة تعطيك جميع البيانات الجديدة 🙂 جعفر

السلام عليكم هذه المجالات تكوّنها الدالة DECALER أو OFFSET كما ذكرت لك بالأعلى... وهي (الدالة) تقوم بإزاحة نطاق حسب 4 متغيرات : الصف ، العمود (ضروريان) ، الارتفاع ، العرض (غير ضروريان)... يمكنك مراجعة خصائص هذه الدالة وكيفية استعمالها باستعمال خاصية AIDE أو HELP... بن علية حاجي

الملف المرفق فيه تعديل على المعادلة و النتيجة صحيحة ان شاء الله (Ctrl+Shift+Enter) =IF(N(O5)=0,O5,SUM(IF(ISNUMBER($O$5:$O$129)*(O5<$O$5:$O$129),1/COUNTIF($O$5:$O$129,$O$5:$O$129)))+1) الملف ترتيب4 Salim.rar

اعرض الملف الفرق بين تاريخين بالميلادي والهجري بسم الله الرحمن الرحيم السلام عليكم ورحمة الله وبركاته كل عام أنتم بخير وسعادة ورضا ============== استكمالا لسلسلة ما خف وزنه وغلا ثمنه موعدنا اليوم مع ملف يحتاجه كل مهتم بالتواريخ في الأكسس مثل حساب العمر أو مدة بينتاريخين ------------------------------- سواء بالتقويم الميلادي أو الهجري ////////////////////////// سواء التاريخ منسق كتاريخ أو كنص ++++++++++++++++++ ولا ينقصني سوى دعاؤكم لي بالخير في الدنيا والآخرة ********************** الكود يعمل على كل إصدارات الأوفيس دمتم في رعاية الله وحفظه والقادم أفضل إن شاء الله صاحب الملف أ / محمد صالح تمت الاضافه 31 ماي, 2017 الاقسام قسم الأكسيس

أخي الكريم هذا ملف آخر يمكنك من اختيار الملف الذي تريد فتحه ... Open Excel File Using File Dialog On UserForm.rar

السلام عليكم ورحمة الله وبركاته أساتذتى واخوتى اليوم أقدم لكم كودا منقولا بعد تعديله وترجمته لتحديد الفترة التجريبية لملف اكسل . فكرة الكود : عند فتح الملف يتم انشاء ملف نصى دون شعور المستخدم يتم تحرير تاريخ ووقت بداية فتح الملف فى الملف النصى بقورمات معين كما يظهر فى الكود بعد ذلك يقارن اكسل تاريخ اليوم مع التاريخ المحرر فى الملف النصى حتى تنتهى أيام الفترة التجريبية فاذا انتهت الفترة التجريبية يتم الآتى : 1 - اغلاق ملف الاكسل و عدم قدرتك على فتحه 2 - انشاء مجلد جديد تجد فيه : ملف نصى نشكرك فيه على تجربة المنتج وأوراق العمل فى الملف الأصلى تحفظ لك كل على حدة فى ملف مستقل الكود وعليه الشرح : Option Explicit Private Sub Workbook_Open() Dim StartTime#, CurrentTime# '---------------------------------------------------------- ' اعداد الفترة التجريبية كالتالى ' Integers 1, 2, 3,30 ,365 ...etc = number of days use ' 1/24 = 1hour , 1/48 = 30Mins , 1/144 = 10Mins use Const TrialPeriod# = 30 ' 30 days trial '---------------------------------------------------------- 'انشاء ملف مبهم المسار والاسم لتحديد بداية الفترة التجريبية Const ObscurePath = "C:\" Const ObscureFile = "Test File Log.Log" 'اذا كان الملف ذو المسار والاسم المحدد فارغا فان If Dir(ObscurePath & ObscureFile) = Empty Then ' بداية الوقت = تاريخ اليوم والوقت الحالى بالتنسيق الخاص StartTime = Format(Now, "#0.#########0") 'جواب الشرط : افتح الملف ذو المسار والاسم المحدد Open ObscurePath & ObscureFile For Output As #1 'تابع جواب الشرط : اكتب فى الملف بداية الوقت Print #1, StartTime Else ' فى حالة عدم تحقق الشرط فان 'افتح الملف ذو المسار والاسم للتحقق من وقت البداية Open ObscurePath & ObscureFile For Input As #1 Input #1, StartTime ' الوقت الحالى = تاريخ اليوم والوقت الحالى بالتنسيق الخاص CurrentTime = Format(Now, "#0.#########0") 'اذا كان الوقت الحالى أقل من بداية الوقت + الفترة التجريبية If CurrentTime < StartTime + TrialPeriod Then Close #1 ' غلق الملف المبهم قيد الاستعمال Exit Sub ' الخروج من الاجراء Else ' فى حالة عدم تحقق الشرط If [A1] <> "Expired" Then ' اذا كانت الخلية لا تساوى النص "Expired" فان ' رسالة للمستخدم بانتهاء الفترة التجريبية وعدم صلاحية الملف للاستعمال MsgBox "Sorry, your trial period has expired " & vbLf & _ "your data will now be extracted and saved for you..." & vbLf & "" & vbLf & _ "This workbook will then be made unusable." Close #1 ' غلق الملف المبهم قيد الاستعمال SaveShtsAsBook ' استدعاء كود حفظ البيانات للمستخدم [A1] = "Expired" ActiveWorkbook.Save ' حفظ الملف Application.Quit ' اغلاق اكسل نهائيا ElseIf [A1] = "Expired" Then ' اذا كانت الخلية تساوى النص "Expired" فان Close #1 ' غلق الملف المبهم قيد الاستعمال Application.Quit ' اغلاق اكسل نهائيا End If End If End If Close #1 End Sub Sub SaveShtsAsBook() ' كود حفظ بيانات المستخدم بحيث كل شيت يحفظ فى ملف منفصل Dim MyFilePath As String, Sheet As Worksheet, SheetName As String, N As Integer MyFilePath = ActiveWorkbook.Path & "\" & Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4) With Application .ScreenUpdating = False ' ايقاف تحديث الشاشة .DisplayAlerts = False ' ايقاف التنبيهات On Error Resume Next ' فى حالة الخطأ تجاهله MkDir MyFilePath ' انشاء مجلد فارغ باسم الملف For N = 1 To Sheets.Count ' حلقة تكرارية بعدد أوراق الملف Sheets(N).Activate ' تنشيط الشيت SheetName = ActiveSheet.Name ' اعتبار المتغير = اسم الشيت Cells.Copy ' نسخ كامل الشيت Workbooks.Add (xlWBATWorksheet) ' انشاء ملف اكسل جديد With ActiveWorkbook ' مع الملف النشط With .ActiveSheet ' مع الشيت النشط .Paste ' لصق البيانات فيه .Name = SheetName ' تسمية الشيت النشط [A1].Select ' تنشيط الخلية End With ' حفظ الملف النشط فى المجلد باسم الشيت النشط .SaveAs FileName:=MyFilePath & "\" & SheetName & ".xls" ' غلق الملف النشط مع حفظ البيانات .Close SaveChanges:=True End With .CutCopyMode = False ' تفريغ الذاكرة العشوائية Next ' الشيت التالى End With ' انشاء ملف نصى به تعليمات هامة للمستخدم بداخل المجلد Open MyFilePath & "\Read Me.log" For Output As #1 ' كتابة الأسطر التالية فى الملف النصى Print #1, "Thank you for trying out this product." Print #1, "If it meets your Requirements, visit :" Print #1, "http://www.officena.com " Print #1, "to purchase the full version..." Print #1, "" Print #1, " --------- Regards -------------" Print #1, "Mokhtar Hussien officena team" Close #1 ' غلق الملف النصى End Sub الكود يوضع فى حدث Workbook بامكانك تعديل مسار الملف النصى وبامكانك تعديل الفترة التجريبية الى مدة زمنية محددة أو شهور أو سنوات كما يتضح فى التعليق المحرر فى الكود لتجربة الكود : اذهب الى الملف النصى ستجد رقما زى كده : 42298.7085185185 ده هو وقت تشغيل الملف نقص الفترة التجريبية المحددة فى الكود من الرقم الصحيح 42298. يعنى نخلية 42250 مثلا ونحفظ الملف النصى على كدة روح افتح الملف هتلاقى الملف يقلك لا شكرا على كده وهحفظلك بياناتك عشان متزعلش مرفق للتجربة : Trial Version Ended 30 days.rar

سلمت يداك اخي الاسيوطي عمل رائع يضاف لقائمه اعملك بس ياتري عندك فكره جديده لتجديد الفتره بعد انتهاء الفتره

وعليكم السلام ربما يفيدك هذا الرابط http://www.officena.net/ib/topic/58789-ماهو-افضل-برنامج-لإضافة-ملف-فلاش-الى-الاكسل/?do=findComment&comment=375462

اخي لا اعتقد ان ذلك ممكن اذا كنت تقصد انك عندما تعدل في ملف اكسيل ينعكس ذلك على ملف فلاشي اما ان كان لديك ملفات فلاش مسجلة سابقا فذلك ممكن

أخي الحبيب أبو يوسف جرب التعديل البسيط في الكود Sub SplitWB() 'يقوم الكود بفصل بيانات كل موظف في مصنف جديد مقسم إلى أوراق عمل جديدة '-------------------------------------------------------------------- 'تعريف المتغيرات Dim WB As Workbook Dim Arr Dim I As Long 'إلغاء خاصية اهتزاز الشاشة Application.ScreenUpdating = False Application.DisplayAlerts = False 'تعيين قيمة للمتغير ليساوي كل القيم في النطاق الحالي في ورقة العمل 'المتغير يخزن البيانات على شكل مصفوفة Arr = ThisWorkbook.Sheets("Sheet1").Cells(1).CurrentRegion.Value 'حلقة تكرارية من الصف الثاني وحتى آخر صف به بيانات 'الحد الأعلى للبعد الأول للمصفوفة ألا وهو بعد الصفوف [UBound(Arr, 1)] حيث يمثل هذا الجزء For I = 2 To UBound(Arr, 1) 'ليساوي المصنف الجديد [WB] تعيين المتغير Set WB = Workbooks.Add 'بدء التعامل مع المصنف الجديد With WB 'إضافة ورقة عمل باسم "ملاحظات" ، ووضع البيانات المرتبطة من العمود التاسع بالمصفوفة With .Sheets.Add .Name = "ملاحظات" .Range("A1") = "ملاحظات" .Range("B1") = Arr(I, 9) .Columns.AutoFit End With 'إضافة ورقة عمل باسم "الأداء والمعلومات المالية" ، ووضع البيانات المرتبطة من العمود الرابع والسابع والثامن بالمصفوفة With .Sheets.Add .Name = "الأداء والمعلومات المالية" .Range("A1").Resize(3, 1) = Application.Transpose(Array("التقييم السنوي", "الراتب", "البدلات")) .Range("B1") = Arr(I, 4) .Range("B2") = Arr(I, 7) .Range("B3") = Arr(I, 8) .Columns.AutoFit End With 'إضافة ورقة عمل باسم "المعلومات الأساسية" ، ووضع البيانات المرتبطة من العمود الأول والثاني والثالث والخامس بالمصفوفة With .Sheets.Add .Name = "المعلومات الأساسية" .Range("A1").Resize(5, 1) = Application.Transpose(Array("اسم الموظف", "تاريخ التعيين", "الجنسية", "الوحدة", "الشعبة")) .Range("B1") = Arr(I, 1) .Range("B2") = Arr(I, 2) .Range("B3") = Arr(I, 3) .Range("B4") = Arr(I, 5) .Range("B5") = Arr(I, 6) .Columns.AutoFit End With 'وهي ورقة عمل افتراضية في أي مصنف جديد [Sheet1] حذف ورقة العمل المسماة .Sheets("Sheet1").Delete 'حفظ المصنف الجديد في نفس مسار المصنف الحالي باسم البيان الموجود في العمود الأول بالمصفوفة .SaveAs ThisWorkbook.Path & "\" & Arr(I, 1) & ".xlsx" 'إغلاق المصنف الجديد الذي تم حفظه .Close End With 'الانتقال لصف جديد والتعامل مع مصنف جديد Next I Application.DisplayAlerts = True 'إعادة تفعيل خاصية اهتزاز الشاشة Application.ScreenUpdating = True 'رسالة تفيد بانتهاء عمل الكود MsgBox "Done !", vbInformation End Sub تم إضافة سطرين لإلغاء رسائل التنبيه وإعداة تفعيلها بعد انتهاء الكود الغريب أن الكود يعمل معي بدون رسالة الخطأ وعلى نفس النسخة 2007

Sub Mail_ActiveSheet() 'Working in Excel 2000-2013 Dim FileExtStr As String Dim FileFormatNum As Long Dim Sourcewb As Workbook Dim Destwb As Workbook Dim TempFilePath As String Dim TempFileName As String Dim OutApp As Object Dim OutMail As Object With Application .ScreenUpdating = False .EnableEvents = False End With Set Sourcewb = ActiveWorkbook 'Copy the ActiveSheet to a new workbook ActiveSheet.Copy Set Destwb = ActiveWorkbook 'Determine the Excel version and file extension/format With Destwb If Val(Application.Version) < 12 Then 'You use Excel 97-2003 FileExtStr = ".xls": FileFormatNum = -4143 Else 'You use Excel 2007-2013 Select Case Sourcewb.FileFormat Case 51: FileExtStr = ".xlsx": FileFormatNum = 51 Case 52: If .HasVBProject Then FileExtStr = ".xlsm": FileFormatNum = 52 Else FileExtStr = ".xlsx": FileFormatNum = 51 End If Case 56: FileExtStr = ".xls": FileFormatNum = 56 Case Else: FileExtStr = ".xlsb": FileFormatNum = 50 End Select End If End With ' 'Change all cells in the worksheet to values if you want ' With Destwb.Sheets(1).UsedRange ' .Cells.Copy ' .Cells.PasteSpecial xlPasteValues ' .Cells(1).Select ' End With ' Application.CutCopyMode = False 'Save the new workbook/Mail it/Delete it TempFilePath = Environ$("temp") & "\" TempFileName = "Part of " & Sourcewb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss") Set OutApp = CreateObject("Outlook.Application") Set OutMail = OutApp.CreateItem(0) With Destwb .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum On Error Resume Next With OutMail .to = "tawakoolah@gmail.com" .CC = "" .BCC = "" .Subject = "This is the Subject line" .Body = "Hi there" .Attachments.Add Destwb.FullName 'You can add other files also like this '.Attachments.Add ("C:\test.txt") .Send 'or use .Display End With On Error GoTo 0 .Close savechanges:=False End With 'Delete the file you have send Kill TempFilePath & TempFileName & FileExtStr Set OutMail = Nothing Set OutApp = Nothing With Application .ScreenUpdating = True .EnableEvents = True End With End Sub