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

بناءً على طلب وملاحظة الأستاذ موسى ( مشكوراً )، تمت التعديلات الجديدة في النسخة التالية بحيث :- ♻ تظهر أسماء الأعمدة البرمجية والعناوين التي تخصها في الصف الأول كما في الصورة أدناه ( مثال ) .. ♻ الفكرة تم تطبيقها على الإستيراد المتعدد والغير متعدد أيضاً .. 💢 Excel Importor 2025.accdb 💢

🙂

ومشاركة مع استاذى واخى الحبيب الاستاذ @Foksh طريقتى المتواضعة zint barcode generator V2.zip

السلام عليكم قاعدة التطبيق تم عملها على أكسس 2003 وهى تعمل أيضاً على أى أكسس حتى 2024 أكواد القاعدة تحتوى على الكثير والكثير من الأفكار والحيل الرائعة لمحترفى أعضاء المنتدى منهم أبو هادى والأخت زهرة وسيد عبدالعال وابو خليل وغيرهم من الأحباء القدامى والجدد لا أدعى أن البرنامج قد حقق الكثير من أهدافه ، لكنه أرضى كل مدرسة هنا قامت باستخدامه الرقم السري للدخول " 1 " ويمكن تغييره فى الإعدادات وإليكم بعض الصور لشاشاته تحياتى لجميع أعضاء أوفيسنا ، والشكر الكبير لهذا المنتدى العريق بيانات المدرسين.rar

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

تسلم الأيادي مستر @Foksh 😊🌼🌹🌷 لااااااااااا ... ذي محتاجة شرح لحالها 😎🖐

السلام عليكم في اعمالي دوما اجعل خصائص النماذج والتقارير منبثق ( pop Up) = نعم و النمط النموذجي (modal ) = نعم وكذلك التقارير مخالفا في ذلك طريقة الاستاذ جعفر .. حيث اوضح في احدى مشاركاته انه يتجنب هذه الخصيصة . ولكن في معمعة التصميم اجعلها كلها = لا والسبب انني احتاج الى فتح اكثر من نموذج وتقرير والتعامل معها في نفس الوقت واحيانا انتهي من المشروع واضبط الجميع على الخصيصة = نعم ثم يطرأ تعديلات في المشروع على اكثر من نموذج وتقرير وهنا انا ملزم بتغيير الخصيصة الى = لا من اجل تسهيل العمل والتنقل احيانا يكون التعديل على 3 او 4 نماذج او اكثر ولكم ان تتخيلوا ان المشروع احيانا يشتمل على اكثر من 20 نموذجا ومثلها او اكثر من التقارير وفي النهاية ومن باب الحرص على الضبط .. اقوم بفتح جميع النماذج والتقارير للتأكد من ان الخصيصة على ما يرام ، وهذا لا شك مرهق ويأخذ من الجهد والوقت الكثير .. لذا هداني الله لدالة تقوم بالعمل نيابة عني في جزء من الثانية تجدون ادناه الدالة لتفعيل الخصائص المختارة .. ولاحظوا انه يمكن عكس العملية وبسهولة الدالة عامة لجميع الخصائص .. عليك اختيار الخصيصة فقط لتعميمها على جميع النماذج ومثلها ايضا على جميع التقارير 'تطبيق على جميع النماذج Public Function funforms() Dim frm As Object For Each frm In CurrentProject.AllForms DoCmd.OpenForm frm.Name, acDesign Forms(frm.Name).PopUp = True Forms(frm.Name).Modal = True Forms(frm.Name).ShortcutMenu = False DoCmd.Close acForm, frm.Name, acSaveYes Next End Function ' ومثلها للتقارير Public Function funreports() Dim rep As Object For Each rep In CurrentProject.AllReports DoCmd.OpenReport rep.Name, acDesign Reports(rep.Name).PopUp = True Reports(rep.Name).Modal = True Reports(rep.Name).ShortcutMenuBar = "cmb_Copy_Sort_Filter" 'قائمة استاذنا جعفر المختصرة DoCmd.Close acReport, rep.Name, acSaveYes Next End Function

السلام عليكم ورحمة الله وبركاته استاذى الجليل و معلمى القدير و والدى الحبيب الاستاذ @ابوخليل ممكن نكتب الكود بالشكل ده ليكون دالة واحدة فقط ' دالة لتطبيق الإعدادات على النماذج والتقارير Public Sub ApplySettingsToAllObjects() Dim obj As Object On Error Resume Next ' تجاهل الأخطاء لتجنب توقف الكود ' تطبيق الإعدادات على النماذج For Each obj In CurrentProject.AllForms DoCmd.openForm obj.Name, acDesign Forms(obj.Name).PopUp = True Forms(obj.Name).Modal = True Forms(obj.Name).ShortcutMenu = False DoCmd.Close acForm, obj.Name, acSaveYes Next ' تطبيق الإعدادات على التقارير For Each obj In CurrentProject.AllReports DoCmd.openReport obj.Name, acDesign Reports(obj.Name).PopUp = True Reports(obj.Name).Modal = True Reports(obj.Name).ShortcutMenuBar = "cmb_Copy_Sort_Filter" ' قائمة استاذنا جعفر المختصرة DoCmd.Close acReport, obj.Name, acSaveYes Next On Error GoTo 0 ' إعادة تفعيل التعامل مع الأخطاء MsgBox "تم تطبيق الإعدادات على جميع النماذج والتقارير بنجاح!", vbInformation End Sub وزيادة فى الخير واثراء للموضوع هذا الموضوع ايضا لاشرطة الاوامر المختصرة

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

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

السلام عليكم ورحمة الله وبركاته ، أخواني وأساتذتي ومعلمينا ( دون استثناء ) كثير منا يبحث عن QR ( رمز إستجابة سريعة ) ولكن ملوّن !! ونستطيع التحكم باللون حسب حاجته !! اليوم بطريقة بسيطة يتم تنفيذها بكل سلاسة سنحقق ذلك . والفائدة على سبيل المثال :- الإبتعاد عن النمط التقليدي اللون الأسود المعروف به رمز الـ QR .. شكل جمالي ملفت لرمز الإستجابة QR .. التمييز بين الأقسام أو الأستخدام للـ QR حسب حاجة المشروع . فمثلاً ( قسم المحاسبة لهم رمز باللون الأزرق ، قسم الصيانة لهم رمز باللون الأسود ، المعلمين رمز باللون الأحمر ..... إلخ . والكثير من الإستخدامات التي لا تخطر ببالي حالياً . تأكد من تثبيت إصدار NET Framework 4.0 أو أعلى على جهازك . تستطيع التحميل من هذا الرابط ، أو بشكل مباشر من هذا الرابط . برنامج ImageMagick . ويمكنك تحميله من رابط الموقع من هذا الرابط ، أو بشكل مباشر من هذا الرابط . ملفات الـ DLL ( zxing.interop.dll ، zxing.dll ، zxing.interop.tlb ) والتي هي مكتبات سيتم إضافتها الى محرر الأكواد VBA في آكسيس لاحقاً طريقة التثبيت والإضافة ( موجودة في الملف المرفق ) . أولا يلزمنا تسجيل المكتبات المستخدمة في المشروع ( وهنا سنستخدم ZXing لتنفيذ مهمتنا ) وطبعاً سنحتاج مكتبة QRCode ، ويجب تسجيلها ليتم إضافتها في آكسيس في مكتبات الـ VBA > Tools > References . فكيف ننفذ هذه الخطوة المهمة . بعد التأكد من تثبيت المستلزمين السابقين :- افتح موجه الأوامر CMD كمسؤول ( Run as Administrator ) . قم بكتابة السطر التالي لتسجيل المكتبة :- cd C:\Users\Golden\Desktop\QR\QrCodeZXing\ZXing_Library --------------------- حيث هنا ، المسار C:\Users\Golden\Desktop\QR\QrCodeZXing\ZXing_Library Dll مسار المجلد الذي يحتوي ملفات الـ التي تحدثنا عنها من ضمن المستلزمات ، وسيكون متغيراً حسب جهازك قم بكتابة السطر التالي :- C:\Windows\Microsoft.NET\Framework64\v4.0.30319\regasm.exe /codebase zxing.interop.dll ومن المفترض أن تظهر معك النتيجة بهذا الشكل :- أما خلاف ذلك فأن عملية تسجيل المكتبة لم تنجح ولن يتم إضافتها إلى محرر الأكواد VBA كما نريد . الآن لاستكمال عملية تسجيل المكتبة وإضافتها الى محرر الأكواد VBA ، نطبق آخر خطوة وهي :- C:\Windows\Microsoft.NET\Framework64\v4.0.30319\regasm.exe /codebase "C:\Users\Golden\Desktop\QR\QrCodeZXing\ZXing_Library\zxing.interop.dll" /tlb:"C:\Users\Golden\Desktop\QR\QrCodeZXing\ZXing_Library\zxing.interop.tlb" --------------------- حيث هنا ، المسار C:\Users\Golden\Desktop\QR\QrCodeZXing\ZXing_Library\ Dll مسار المجلد الذي يحتوي ملفات الـ التي تحدثنا عنها من ضمن المستلزمات ، وسيكون متغيراً حسب جهازك الآن نفتح قاعدة بيانات جديدة ، ونذهب إلى محرر الأكواد ( Tools > References ) ، ونبحث عن المكتبة التالية كما في الصورة :- الآن وبعد إتمام عملية التسجيل للمكتبة المطلوبة وتثبيت المستلزمات السابقة ، نقوم بإنشاء نموذج يحتوي على مربع نص ، وعنصر صورة ، و زر لتنفيذ العملية . ثم نأتي إلى الأكواد ، وما سنحتاجه الآن هو مديول يحتوي على الدالتين التاليتين :- '********************************************** '*** *** '*** 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 Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr) #Else Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) #End If Function Encode_To_QR_Code_To_File(str As String, Optional foregroundColor As String = "black", Optional backgroundColor As String = "white") As String On Error GoTo ErrorHandler Dim writer As IBarcodeWriter Dim qrCodeOptions As QrCodeEncodingOptions Dim filepath As String Dim folderPath As String folderPath = Left(CurrentDb.Name, InStrRev(CurrentDb.Name, "\")) & "QRImage" If Dir(folderPath, vbDirectory) = "" Then MkDir folderPath End If filepath = folderPath & "\QRCode_" & Format(Now, "yyyyMMdd_hhmmss") & ".png" Set qrCodeOptions = New QrCodeEncodingOptions Set writer = New BarcodeWriter writer.Format = BarcodeFormat_QR_CODE Set writer.Options = qrCodeOptions qrCodeOptions.Height = 200 qrCodeOptions.Width = 200 qrCodeOptions.CharacterSet = "UTF-8" qrCodeOptions.Margin = 1 qrCodeOptions.ErrorCorrection = ErrorCorrectionLevel_H writer.WriteToFile str, filepath, ImageFileFormat_Png If Change_QR_Code_Colors_ImageMagick(filepath, foregroundColor, backgroundColor) Then Encode_To_QR_Code_To_File = filepath Else Encode_To_QR_Code_To_File = "" End If Exit Function ErrorHandler: Encode_To_QR_Code_To_File = "" MsgBox "حدث خطأ أثناء إنشاء QR Code: " & Err.Description, vbCritical, "خطأ" End Function Function Change_QR_Code_Colors_ImageMagick(filepath As String, foregroundColor As String, backgroundColor As String) As Boolean On Error GoTo ErrorHandler Dim batchFilePath As String Dim batchContent As String Dim result As Long If Dir(filepath) = "" Then MsgBox "لم يتم العثور على الملف: " & filepath, vbCritical, "خطأ" Exit Function End If batchContent = "@echo off" & vbCrLf & "magick " & Chr(34) & filepath & Chr(34) & " -fill " & foregroundColor & " -opaque black -fill " & backgroundColor & " -opaque white " & Chr(34) & filepath & Chr(34) batchFilePath = Environ$("temp") & "\ChangeQRColors.bat" Open batchFilePath For Output As #1 Print #1, batchContent Close #1 result = Shell("powershell -Command Start-Process " & Chr(34) & batchFilePath & Chr(34) & " -Verb RunAs", vbHide) DoEvents Sleep 3000 If Dir(filepath) <> "" Then Change_QR_Code_Colors_ImageMagick = True Else Change_QR_Code_Colors_ImageMagick = False End If Kill batchFilePath Exit Function ErrorHandler: Change_QR_Code_Colors_ImageMagick = False MsgBox "حدث خطأ أثناء تغيير ألوان QR Code: " & Err.Description, vbCritical, "خطأ" End Function وفي حدث عند النقر لزر التنفيذ ، الكود التالي :- Private Sub Command20_Click() Dim imagePath As String Dim folderPath As String If IsNull(Me.Text0) Or Me.Text0 = "" Then MsgBox "QR Code الرجاء إدخال نص لإنشاء", vbExclamation, "" Exit Sub End If Dim foregroundColor As String Dim backgroundColor As String foregroundColor = "Blue" backgroundColor = "white" imagePath = Encode_To_QR_Code_To_File(Me.Text0, foregroundColor, backgroundColor) If imagePath <> "" Then Me.Image0.Picture = imagePath MsgBox " بنجاح QR Code تم إنشاء", vbInformation, "" folderPath = Left(CurrentDb.Name, InStrRev(CurrentDb.Name, "\")) & "QRImage" Else MsgBox "فشل في إنشاء QR Code", vbCritical, "" End If End Sub الآن لتغيير ألوان الـ QR كخلفية أو لون الرمز نفسه ، تستطيع التعديل من خلال السطرين التاليين في زر التنفيذ :- foregroundColor = "Blue" <---- هنا لون الرمز نفسه backgroundColor = "white" <---- هنا لون الخلفية وهنا نكون قد وضحنا المطلوب وطريقة تنفيذه خطوة بخطوة .. QrCodeZXing.zip

تحية طيبة أخي الكريم بعد التجربة الملف (في النموذج) لا يقبل أي تعديلات ولا تغييرات في درجات الطلاب الموجودة وجزاك الله كل الخير

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

الحد الأقصى لطول السلسلة النصية التي يمكن تحويلها إلى رمز استجابة سريع (QR Code) يعتمد على عدة عوامل: إصدار QR Code (Version). مستوى تصحيح الخطأ (Error Correction Level). نوع البيانات (Data Mode). 1. إصدار QR Code (Version): هناك 40 إصدارًا من: QR Code من الإصدار 1 إلى الإصدار 40. كل إصدار له عدد مختلف من الوحدات (Modules) التي تحدد سعة البيانات. الإصدار 1 هو الأصغر 21x21 وحدة ، بينما الإصدار 40 هو الأكبر 177x177 وحدة . 2. مستوى تصحيح الخطأ (Error Correction Level): يحدد مستوى تصحيح الخطأ مقدار البيانات الإضافية التي يتم إضافتها لاستعادة المعلومات في حالة تلف جزء من QR Code. هناك أربعة مستويات: المستوى نسبة تصحيح الخطأ السعة النسبية L (Low) ~7% الأعلى M (Medium) ~15% متوسط Q (Quartile) ~25% أقل H (High) ~30% الأقل كلما زاد مستوى تصحيح الخطأ، قلت سعة البيانات التي يمكن تخزينها. 3. نوع البيانات (Data Mode): يحدد نوع البيانات كيفية ترميز المعلومات في QR Code. الأنواع الرئيسية هي: النوع الوصف السعة النسبية Numeric أرقام فقط (0-9) الأعلى Alphanumeric أرقام وحروف وأحرف خاصة محددة (مثل $, %) متوسط Byte أي بيانات ثنائية (مثل UTF-8) أقل Kanji أحرف يابانية الأقل الحدود القصوى لسعة البيانات: بناءً على الإصدار ومستوى تصحيح الخطأ ونوع البيانات، إليك الحدود القصوى التقريبية: الإصدار Numeric Alphanumeric Byte Kanji 1 41 25 17 10 10 652 395 271 167 20 1,391 845 579 358 40 7,089 4,296 2,953 1,817 Numeric: أرقام فقط. Alphanumeric: أرقام وحروف وأحرف خاصة. Byte: أي بيانات ثنائية (مثل Base64). Kanji: أحرف يابانية.

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

اذا انت مدرك لما سوف يحدث وتريد الاستمرار استخدم الاكواد التالية Function ConvertImageToBase64(filePath As String) As String Dim fileNumber As Integer Dim fileData() As Byte Dim base64 As String Dim i As Long ' فتح الملف كبايتات fileNumber = FreeFile Open filePath For Binary Access Read As fileNumber ReDim fileData(LOF(fileNumber) - 1) Get fileNumber, , fileData Close fileNumber ' تحويل البايتات إلى Base64 base64 = ByteArrayToBase64(fileData) ConvertImageToBase64 = base64 End Function Function ByteArrayToBase64(bytes() As Byte) As String Dim xml As Object Dim node As Object ' إنشاء كائن XML لتحويل البايتات إلى Base64 Set xml = CreateObject("MSXML2.DOMDocument") Set node = xml.createElement("b64") node.DataType = "bin.base64" node.nodeTypedValue = bytes ByteArrayToBase64 = node.Text End Function ' دالة للتجربة Sub TestConversion() Dim filePath As String filePath = "C:\Users\Administrator\Desktop\000000.PNG" ' استبدل بمسار الصورة الفعلي Dim base64String As String base64String = ConvertImageToBase64(filePath) Debug.Print base64String ' سيطبع الناتج في نافذة Immediate End Sub طيب الاكواد السابقة كانت لتشفير الصورة كل ما عليك تمرير قيمتها الى الكود الذى تنشئ من خلال له رمز الاستجابة السريع ولازيدك من الشعر بيتا الاكواد التاليه هى التى تعيد وتعكس العملية السابقة Sub ConvertBase64ToImage(base64String As String, outputFilePath As String) Dim bytes() As Byte Dim fileNumber As Integer ' تحويل Base64 إلى بايتات bytes = Base64ToByteArray(base64String) ' حفظ البايتات كملف صورة fileNumber = FreeFile Open outputFilePath For Binary Access Write As fileNumber Put fileNumber, , bytes Close fileNumber End Sub Function Base64ToByteArray(base64String As String) As Byte() Dim xml As Object Dim node As Object ' إنشاء كائن XML لتحويل Base64 إلى بايتات Set xml = CreateObject("MSXML2.DOMDocument") Set node = xml.createElement("b64") node.DataType = "bin.base64" node.Text = base64String Base64ToByteArray = node.nodeTypedValue End Function ' ودالة التجربة تكون بالشكل التالى على سبيل المثال Sub TestBase64ToImage() Dim base64String As String Dim outputFilePath As String Dim filePath As String filePath = "C:\Users\Administrator\Desktop\000000.PNG" ' استبدل بمسار الصورة الفعلي base64String = ConvertImageToBase64(filePath) ' النص Base64 (يجب أن يكون نص Base64 صالحًا) base64String = base64String ' المسار الذي سيتم حفظ الصورة فيه outputFilePath = "C:\Users\Administrator\Desktop\1\image.jpg" ' استبدل بمسار الملف المطلوب ' تحويل Base64 إلى صورة وحفظها ConvertBase64ToImage base64String, outputFilePath MsgBox "تم حفظ الصورة بنجاح في: " & outputFilePath End Sub طبعا لا تنسى تغيير المسارات بما يناسبك فى وظائف التجربة

طيب مبدئيا لن يتم اضافة الصورة كصورة كما تتخيل السيناريو الذى يحدث قبل ان اجيبك سوف يكون كالتالى الشق الاول : تحديد مسار الصورة وبعد ذلك تمرير المسار الى دالة وظيفتها قراءة الصورة كبايتات باستخدام الوضع الثنائي: Binary , و يتم تخزين هذه البايتات في مصفوفة الشق الثانى : تحويل مصفوفة البايتات الى : bin.base64 ثم استخرج النص المشفر بتنسيق Base64 وتخيل إن الشفرة القادمة دى حتكون نتيجة احد الصور بعد تنفيذ السيناريو السابق : 8e//9b//tx/+zW+OfzjdethdvdyYnq/1DkbBrKF2TOC44FTyRjGn5gs8zQ2/fRDaKs+sVR1Z ClQ51Oi1u5i5aFWBY71pmy3HaDta25abZq2hI0rT1Ns8R71N6wm0Or0u1ANd9wzNETE1B3/s CbvLOI5a7OO4eGzwJnmfxTFVeUGxtPy5oKW6FfEG0Vkf4zKS7Bc9xzFZMONjLhjPD2ZxHCT3 wfEo4j54AW3mx0lxbDiBQa0jPwnH3Gc8LxvTywa6q3wHqHJMdWuPeqyzCH4tSzimd3wp+Br5 e8KfBQp/6aUI8gU4pvucJvvQ/FGS4njedf0zAmHPcRyXjQnHEs1uS2XcoSkDXptGf7ltgxLj 2KKElhtYrme5LsexXGpdQEyq0VqaJ8JKXvAxZJy0WwR0reraikMzEBXLonFuiEm9ELbziowB YpZxEAbPcSxOAsZ0Yhxbjm3Sj6eh2ppqcc+xaDt2pHnZ2MiVdMJx0cgmV7IKFacMH+sN3enY Xt8Jx1591W+sec01r7VO51wntoOxJYrBsK8oEse14TRDCptYc4aqM+D0eT4U+5i3uzMgXYdY nMHxxHanjjdzvRdxnK0c88ohsdLuNRxbkQwBz4+LWvLitVnvZvJeHPPSJYrVwIei99KCkgoK u7xBt08yxjkV5p2C4hW5eCzKz3Rj3FKx87KVl428oucMpxQ0lP4k2NobAsfX9we3j0fI7uFs NG13B2G9jV9L0LDshpJfl3Fj2kQ6qtovVY5lPe45rinFmlKqyWWkqpTLMhePa/l8LQdx5rjV +HlwnOdXIKKfoVTV8BSqaS77ONCt0EDMyDDqFuzrtByv44nKsZAx9Ry3XRxHzIbFuw2/jmP6 z/sb20czjmu5Mu6JvIhjV1YDTYPR2w54Sn6dNMPVdrTeqa93GzzVOOPjV4vHL+YlHIc+D8Hg LovAFRn4bt+jDFxn4ILFwRjx/JHjDWyrSw3BekuhDe1aitqQpLDCs40FjqnRAj4u2qW8WeT9 QSh5aq4olp05jmsh3lGWI/AaONaMFj6sYbZNkvECjr+ocixGuYk5x8m0YxwkFhuZmrHldi3G sRsTuUMlZFvgOCke41UK+1gSPi7peKBBEQ4NCaD98+jhjhtpngPr6+nv+vQTcIwjrzxy+Xy+ UqlZjtZo2YNxfX2zs7c/ODoZnZ5S5fj6AjImHF+dD67PJ4/XkPHk6Xr24Xrt083mt3eb39wB x6sPV5Pb8+H1CTK6Ppncwcdn07uzyd3x8GZf4Lh7unHxhw9/80//7f/ef/I//uf/+l/+i//T v/zH/+y//et/9Luz31xuPe5NLtbHZ6ud/YE7iZS2UQ5qRbeaN0srSo5wbFVp+2h66VbCE7Rs UpMxWAwfU9cXj11kHFtaw1IbplQ3KqFaCmSkGqlyw1BxVcumyTgNC7/7zMgSC/IQnSJk7MU4 9mIcCx/PO4+zOMa7UF7AMUEtkesSlQhkKY5TH7OM5zimf9PHFqSkPk6Kqcs4xpspjm1X4BhR abYG7+oHD1FDxRKOw5+JY/q2sC/juyqwG9DauHmrMWeJxSJLOH6RvAi+2Pk3JIheuxmOU1fJ 54JPlDwQf0dJcfyLBD5WokgK04DFFJ5q3FaRgOdveTG48DfBpDTNBMe2G9puYLtevDLOhUEt 2zURyzVNUaZ18RNBvcUqEJzIOOlFJh/TQaofO4rrKq6jOLaK2LZqwbK2M28sptNcxmEs4zAM g4B0jGvTzorlU4xjy7AhY12xVJrmJqZVUGqKVZbMeJRbUV8BjuNoHH0lr+dLZqHqlNRQMZuG 3YFHHRrftuY31/3Whg8cN1ZjHMfF4KHODo4vg8LzDDRnoNkDJY3TUwWOCbj9WLpO/zmO3RjH 2YFx1FYheo7xQHHPMXDMLE5xTC3FIjF/hX0luy7HMk5YnCbxcUpkOJiaInQKNRkjvAIvmwTH dbAbPqYAyngT19J7+SUFFE5xjHhlyWEcuwVcK8BtcOeG7ORr5krNWKlpKzVlRTHydlBt9e21 7e7x+cbV3b7A8c7+dDButnt+1LK8uor4DTVsqbSxY0vz6zXg2HCKouF47mOjoNC0iqKkliS1 LClIpaZWqnKpLBXh3YKUL0jJzIp4WsU86fxjMjT5mHYGoW2l7ZrmKLqnmgGIrBmhrkUG7Bvj uBv4PPzYEdtKN22rQTEiI8Vx2aiQk7I4Fp3HWRwD6NmujxTHNeC4mO05lj1ZDTX8nbLgtn7g jerBtEky3ug2NnrN1TmOESoeZ4Ycf9bHz3AMGSMgOEAMFvtxBm6coesNgeN4x5wAOB7ads9g qtJEQqOjaC1JiioVj+ZREIsJxwgt1CtYJRo8xbuE5A3CcckuV7w5jmuhwjhWGcdCxhYHF5ba jsnH8ZyKLvIGjrMyjgMuU0NFWjOGjLu22xU4TtJ2HOC4Tp0V3Hls0NiQuY8l2qMX/KBQtU7g WGwu/RXHfyanL8Xxm6d8PlfGg23KQd3qDqPVje7u/vD4dHJ+Pru+FMvyZnfXo5uL4U0Gxx9v 1sHi7x5E5Xj1cY5j8vHN8fDqqH9xMLjaH1ztdc43u2ebg4vth3/zx//mP/vv/M//7//p//7/ /X/9P/5X//l//z/5j//eP/n7V391u/20P7lYG53O2rt9ZxQobbMcyeVALthV/IrJ66WiWRZP R/rVoxbxpKQ981yp5is1j1aV4k05UPWGqdYNKdQqgVry5IJXQ0q+XIGP6+RjKi03Havh2HXb Dm0rcMzApvi0uo5CLbn03+fltooEx3G8YGFaxas4TjtcRZEyI+O0bPwCjp/5eCnPK8dpWwVw LOJ4L+I4aasI8CYtyPtJ0yrwXtRTkeB4KfP7mUTLThF+BccIvm/Zb6MIjosPS68BXjf0O7Nc YE5fb3DwnUy/ivckfYBeecf40aeO8GfMfW+S4XdptGSbPY7YD6+pMI61sK0HPJaWB88mMo5x DBk7TuTaoesEIKuQK3TqUmcvzx52Yh+bHn4iXD2IJ1oIFmuRh/DuerjMBwNX8Smq59I/XhxX B7GXaPwlOH7eVmHaFm0FYrKM0znHlKpivoRjsFhdKSiUHC7o+YpVlPyaVlfNpu71rWhKDRVU PF5/GcdUEiYN04Ushe2+YvcW4nRfwnGPhhln2irspK3CcWlVXzIsmWXszP+0KzQcLdVwsvAu 9jGrlwhLzcQSlJwF8YvB7dnEVCqmbuPsUrykhMypLPqYGiRwnhxhHFOpuBT3UVCr8Qs4Tm5W lmzGMaITjiVtRXdLUVsfrzX2jqZnl1uXN7vI1u5oMG4Ax/W2FTT1sGVEbaPRMeodQ+DYCWgH ad4Yj4a4wceIahKOFb2k6GVFKytqVebdE6tqpayUykqxJGwKJVMhOZdMO14IlCy0mpfyRaVY 1fEsqio2rfLUPYrma0qoG/VlHJOMwaY6lRVFZVHxFMkhHJeMSuFtHEPGKYtFAGWuZDOOC6IH Op5W8RaOFyrHWRyTjxcnVCzOM16OUDL1Swx9xrEwMZWKOQ6FZEzTu/0RWEz7SgLHNMy7b1hd HtfNE7v1tqQ0qjWfxhhncVx2yiWLxiELHwPHBatYsKm0XAs+g2O7iwuG3tb0ZNrx63OOX8Bx 0DXDxfixhilez/ZFuo7XXcRxyzYbFDwBFn2s1Gxan1c2a0hJrxSTnopYxuKB/nr6U59+URzn crliqSCrVUCk3Qtna729/cnZ+dr19ebDnRh1vPF0P3u4Gd9fTZ9upx9uJ083qx9vCcffP259 97D57d3q09Xkbo7j4c1x/+qgdbrTu9wb3uwPrneH17uTm/2nf+vX/+h/8h/8r/8f/7v/8//n v/jP/3//5X/8r/7Z3/7T/0YWx62dnjlwaw2tFEhU+nWlnFYEjgt6qSRwrBbxeyevFopGsUxD KmRaLGzXSka55slKpNEiU18pezLet+jWip4EHJdDpYar6rqKX230up9xHDlwghU6JhJ4kC4F FAMiaVpFuiAvg2O6CjcILdonL7DCADiGt8BQYS9ciPkleiq4X5b7KMiRmYYKGkI833IZb9Yp dj3j44y9sqEPiwtULY5NJm62gGPRWZHgONtWwTim1Xg4Ahz/hDnHomyc4JiaQJIvrWHVGzaN zqDFc/H6Oc6rOBZJqPoGjumr/iVwTAXmbMTiRbob8fczTQLct4KbpV/js/fCQ/9zcYx3jPcL FJOhOfBxpn05xrEatkjGYUfgmDb59bqJjNuW07ScOmQ8x7HjxaMjHMezLZcKvjyEWLRY4FDg GDwF2RBTLCJPj3yt7qv15HLkq6GvBh6i+F7qYwsf8bXKccbHOIDjuDbbViFwjBPj2LZdx7RN zdQ+g2Ntpcil4hjHykoeMuapq3ktVzLy3FwhqSAjvjdj0VjspJ3HaVuFKBXb3DJBOB5qon0C R2IcL/r4VRzzkONnC/LE9tEkY2do8N54vNcXzTmWKU05bpNAfgkc6zTGeEHGIjiSyvilFgsq J1MlmIvBQr1qUJb9Es0ACSsIIVi0VSzguKR4JdkuSFZOsnOSmYOMq9qKYhXcSOqN/Y3d/sHp 6snFBrK5OxrN2r1h1Op5jY7V6FrNnt3qWfBx2FK9es0NKwgNOaYdQEqmS1VkzSqqRkkxyopR UfSKolVl3le8qlUrShk+LrGPqYS8sBXIQtKmixxuIBfKGlRaUWxJdeR4EIqvqqFOleO2K3oq EF6B53BB0aBhRzgPdMWNcVx8CcdkphTH2ZpxBsf5Wq5UK5RwN9RiRa9UTdoIVqadXzX8qTJb jpO0VQRJW0V9Rm3HcUTbcbwyTwRETsKF5GwWcMw+9hnH3tBzkdTEFNpKHTJmHHNGNPB7jmOx lw2HcVyp+qWyW6KNP5wKhToryiWbisd53kWPNg0xi/Axrqr5NfJx8AKOrY5ldQWOdepCbiki ooVjjuNk4DEuvI5jK8Vx0LO8nkPpO36anjvHMa/Ms1u21Ux8HMU+Tvor4GMZPq5Y8HGVHnH2 8Vcc/1mdflEc45TPr1RqJdNRm+1wutrfP1i7vNx+uN//5uPB99/s//DN7nefNj4+zp7uZh/u Zh/v4OPVT3fr394Tjr9/3PzufvbhanyfwfHtce9qv3661bvam9wdTu4Pp/eHs/vDp3/rN//w n/+T/+V/+b/91//V/+3/8v/9L/6H/+qf//1/+g8uf3e79bg3Pl8FjhtbHaVjlkO4tlIJVBi3 YJbh45xaLLGPC3qZVoyqtKd5ySyX7RpSsqhZvuzgh40Lya5cdmsUTyoDyoECHFdDRQpVOdI1 /NKBj2ntRQbHoWeGPiUICcE0raKeyDiD4yRWENohxVhcBgd7kfMStgoeiapwHK4ZA8S063Kr QxGXObT9spj/8FkcZygm3pzjeLGtQjg4g+O4kOzwnOP3l40R4DhZipfBsRB/NP+6LB5LnEWh aAaIk+I4/aJYvQLH6cuMNALH6c1+Jo5fDD6vuAP0Kfhzpd/btyO+82ky7xWzeOn78EXBe80/ iJj3jDSb8PEcxzTDuIloYUuPcUxlY5ZxJ4tj2667NmTMOLYD1/ZFU4VrE44924SPqYTsgqS2 7dP/VQyKY0a+EfnQsF739QanHui0lx5Cg+FAZAXh+rHOTcz4CILF4hTjWJwYx4jnx6VrgWNz PqyCTuRjwrH9LhyryzgWMka4eLxSMrnT0auqAOgAAjagYTG1DTiu0yg3K1lpF4NYVJFFoOQX i8cZHBvLOKb6MeF4YZTb2HYgY6B5oNtd2gGE/sy3ZLNRo9Qz6uWRFD8Tx1pAil2KGOImOPui jCFmce1SeNIFTY/WoqoS8oI8dxHH1H1RUCBmm44rdl4xV6rqiqTnTa/U7FnTjdb2wWj/ZIZs 7o1nG/3RtNUbRe2B2xm6nYHb7tmE46bi1SX42G/U3HqNxh7H+4CUDbusmWXVFDiuIbJOOK5p 1apSFj4ufxbHiVNpfZ5UKKmlKndWKI5Mu9O5iuqreqhTz3HHA4tpO9VB5HZpBR5MDDfTkDUE YHodxyLxEIPXcUxAT3Bc5l2uyiZNq6AFeaHBC/JcZxB447o/a1Pb8VoniqvFn0tmytubhWSa QeEOBYvteYYUHlAIFrvs47hdHi/wnuNYblTKfqHo0uy2ks0+pj/BlZJTLrKPWcZx8MNIOCYf v4xju4sv3DTbus4L/rLJ+lgELy9fwbEV9ezUx0HP9gfuclIct2lZnsCxzZ0z5OP63MdcP1ZE /ZhbLKpFbvKkR/krjv+cTs9xjCOisRiXceELe19y+ZVyuaQbaqMZTWfD/YON6+v9D08nP3x3 9usfT3/z49Gvvhc+Xv94vwYfP93G0yq+f9yGj7+9X3u6nNydDq+OROjyzVH7bGt0c7D2eLr+ 4Wzt8WT17vD+b3/4B/+D/9a/+Nf/i//N//M/+0//X/+H/+7/6j/863/vb09/vFi/3R6ezAaH k3CtWamrBadM/UlureBUc0ZxRc2LZXn4HURDB/VyHk9KWNmsJDiuFPQiziu0HzoFP5kVX6oG cjVQKqEMbVf4shRQVQDPeCOyzdBOZMz7IAQBZAwEi0B+aV6ScWRHFCMIs8x6FcdUFW5RhRiC bBGLPaTdpYjLDGXg8g0c403xYcXx+FMkNdrXcMx17vnAClg5wTENOYZ3lwT8QhpdceE5jhEn ajp4s972GrwzCL4KMZOOA+HR3U6XlHEVWUR8OQa+Vz7HC3FvuaU70ABWvv/4Kl7FMb7M5Cv9 grz0XvhEGR9TeN3e5yMeiDTJI4L80XDcSHAcb3pXV8OGFtJ/pgnHQVun3X47tCAl7qagWE4D OJ5XjoWPHT+uH9sgsUNKJdc6tudYvsM/Gq4Z8f4gdd9AGoHRCI1maNRDPKAc8rEWIr4WeLrP w79phR8VfekjEo1d13c93/EC1ws8P4yDI66HzwoEWxCwYRmGSROSDSgZsal6bDm2bpsqTSKP cSyDDoxj2apKVrmWVo6FjJ/hOPaxkS9Z+INdloHLtgyYegM9HNtgcRM+nroRbYMHH4tuY9Fk HMs49bEoJMf1Yw71HHd1qtEDx8lcNqoHd1UT6WuieEw+FsHloSF2ALE61ExptGh4sFGvUcim ElBLuiUcq25TcxqajRB2FTOUjVBC4tu8kTp1DMO+YoJbGoYvtSADwRZt4ZF2UFCRmOvEL8iY roqqomYMHCO48BqOZTsvWTkmcl4xVqoKfJxTrSKenqPV+ubuYOdwvHs02TmYbO7Cx73RrNkb B72R3x16wHG9bfh1xY+koC5FLdVvyDz2uMr1Y8KxbsHHVdWoZnGcVI7LJaVUhEoTHOeTbuNs z3EGx3gzh3ep6ks41oBgUNjreGBxNKwLHJtNGpBPSKI/IhpVEz+LY9GH+lzGyBKOFWqALtNy 80rNqdEmeckoN7vvuaOQisfTVjgDfHnI8RKFk8wryozjNKmPRWIZ48NS2ZgaiwWOnT4C+1rO wMri2KMqMm0JKf71YZOM8SQnGcc9x3XGsZMvWvkMjqu4ULLLxUUcQ8wV73M47jlGGyCh1X5a Q9brit5IfMxENlqq2aIVe1w51pLtow3uJwaOYWIbOOY4SNh3gqE7z5s4zviY+49Dk/5R4Kuy q9TIx3jQxfo8/m82tx3n5Tw93F9Pf+qTcHA2QsPi+JefcrmVUqmkaUoURePJeG9/5+bm5Jtv rn/z69vf/+769787+82v9r//Zgs4frxdvb+e3l+tPl6vf7jZ+Hi78fFm4+lq9f5scnM8ujwY XhzgfHxNe+N1TzcnN/ubT6fbH8+3PpxtPBzf/PU3f/j3/sF/8C//w//Rv/qf/rP/7H/27/xH /+43/+BXe09H0/P13v64szv0pvVyqOSt8opWyFuVnFleoR3yEhxDw2aNfhMZ5QKgbFWJwi5t lUfjLCz8KNYqYDHikYzxg1cjE0PG1UpAR6SAfulo1DFm6VwYM/gfx4aoGYPFBL60YMwJGsCl 6LWgdgvRUAFGhxTgGFxLE/+PPnVSBseig8KFjNtgcSLjTHAc1zqNpsWdCWwvfChK7Ei6kCb9 FHRBo7sB50F+wLFLF1xPpZ1KAgO4JPQnwf3nWrKT7AASxKvxIOAYwQuBjBs94WNqqwCCI4Q2 o3ZCsFhsv9cCmv0GrdgLAH28AKAuEXzVopG6jvC3Al/UPNSMgYhXI5nCdrLk0dccX3UYxwC0 SFxdpm81ufaLcOx4soh4/ZBRcozjmMUi4hvOSS7H6qWI4/FjnSa+vQgPn07z/2/vzJrbxrID bIk7trsBFzt3cZGsXZa1WbLbnh633d3V00sq05k8zFTN5CEPqVRe85CfnnPOBUCQkmynul2p mmnVVygQuKQoEhQ/HJx7zob4fgpgn8WLBnJs+gUSPM28xHS8Qzw4NYoyFuVIWMDDXGggAyQQ ZNLHnGPlx8qPCoLQTMujNAjta620ljoARBjwiD4XFDZGUlDkRGQpkhbvZqXIPI4MeIYZwiP4 FaDaSiulpQqlihCfUKFQWsiAC59RmTbmSYCDDXMfkNxXgOeLYjaedBxhYYtdaTnSsjE7s9uT 7a5otsF92VYTC1ZsNbytlRzbBCVXNHijJZqWbrOsJwd2MPbiHZnMVbbw04VPcqyimYh2OE6V Q3hgylNMS4wl47S8ItfCn3jGjMMxmLHA+PGI+UNPDV3wY+wRjc2iOXXFAyc2UG88vBxMcpwb OS4QKLWgtq7KAM/PmZ9xlTGVeDJxRezy2OGxLciVCfthUgust5Bj0NYSdF/YSCkT2FnaUPQK WRtZx9zLIzmm3h+w3sUsC910sVrFKq0CS1X46Mdu0HTktm3Sjt1tplpR7oEBY7e80wn68fPl 6fku+PHe4WS+l0/m8XAa5COZ9jme69HlEJTjlOQ4Qjnmfov7baY6TPaYtDxhe9xyuWXxtbSK ht3Ytra3e9v3y1ZQtQraSLZaynGzLscuplV4PJUqx4TjaIJh42gS+0MNcuziJDzX1raNSwcb taIc91q8g3FEk/JHzVwNm3IMK3VQ2be2rUbTbrScRttttVmrDYe037W05cSel3ExVHLs+9NQ z5JonsWLHKv4I0aRN8hTAlYw/7hOqcUrOQYzRjnWJMc+UpNjWMeECmyKDh+NQIMW70hYBtgg XUg4u4MjnE4CjRzbabcbtdpBk1pGY+ZxK+gifqepWg3Z3BaNiialHYMfd0Mjx66beV7O+UDw gcQ/eQT44MogzW5qe6nNEhf8mGeAi6AieyJnou/Kvqf6phIFmTGVoQhHKiYhjsdBPNbIRCc7 BTERTXU41uEo0JhWAXLs+wasRkJ+jPkVUlCWOcPkCtfGKZjgx3hGBG/6b3L8D/BDctx0XUvD ufLO4uTs/Is3r7797qs//vzuT3/68uc/3v74w/k37w6/fL376nZ+dzO/u168vF4Si5dXi7uL OQjx7bP5zdns5nR2czK9PB5fHo4v95d3p4dfXp6+e3H2/haWtz++ff/nn/71P//6b//9H//+ P//1zV9+ev7+dnl9OD5b5IfTdH/sz5Jeypqq94SBFpdgHkVzJcei00BAhWlCXuTAshvYaMlB r4uZ/viRI+wefPxCnCvQi7pWbMFJKlZHjoUTS5dSKqkxWEgCCtIDVgoy11fJQMUlUa5omj9N 1DM5u1jtATtIR6FAJ1jpUQVsrMuxn/XRfT8OqHPu56lMwTnwmjX2M0sikcQAyEexBSwEzQnA jV4UOqF2NDgxlQ4IlMHVPouKhsBF0kgcyjiihJDETzCtgrwWDTjJxwisbDJOkkmS0q50ECeD MBlECPoxPUKOkk3bQZ3DbICKTGCCMvzhNIYCzGvQ9rJ1H5yTrPwYX2EGWqwQrotElwIKMK+F kD8FcmJLBT1aoh8byI8LM67eNVop3kqT8kHpFuC4Jo6LoXqqm+GGWGnuM1E9GdTxKoRcUgg3 jMRneA8Uejye6WSPqnTTawsnHhyvJ1RoHoDLahmanCI4qnGLpwM3DDAYTAePgWR982msA88z gQNMYpJSICJfhAoLwmAFDOYFnhu4FawAszxNxM7UHfd8Tr2ppam7DCtewN2AOcpzhGNJx1KO oxwbL25iCVL4lmqLdps3W6zRZI2Gt13IsWnuClAKMs7SA1fzmyztyb4NCgtGG01l0fyZgmSw TAASArhZVGcbU0oxAOs71N8OQc31xwwexBCMAPhuLhtxFVOFqgn1dYoZeHLgiLwGZlB4qMIr BMFVwmTCRIzw2ANFZgUWx0SLklV2BMahMTnYlCV+CLcAfbeKB2+MqYCRRos3NhotXgNOPwLE EY2e+8T2njDZCCIrzlk+lujH+32S491nF0/Prw5OL3YPTuArB07MZZx76YD1RzIfiWTg6dTy EzDjntQdHpiGebAES7ZF4ErfE8plEq8nWEVaRZMKHjfAjB/MZCAbxhAyurK5aW213GY9rQKO Rh4xECMwpGAA5hRq6oqn+gEYMzZO03Dg4bS5iq6iGVp0SRP1yFxer6DfVQDrG3tBnSlBuek2 2l6jDWd6qpJjx8sY+CKYoj8BfwU/jqN5Ei+yZPkQizRZJPEcHLoU30+AcirAjIs8CkMVMAYt jucaW+egH+MwfyrVWFTgtLwhJgR7me0kPSvuduNuO+y1dLcRtBt+u6FaW6L5RDTqbMtWU+G8 vQ58OyeOnXluzr2BZENl4EMlBpLnnCUeajHCeOrCZ0SkHgIrGRNw8pAzmXOVC9WnpncDhX09 RjjTLhxTbHgCBhwC8TTKZgmQzpJkB4iBaAK7Kj+uQTPzVC5lhj3zyI/hyTDwY3O5oCN+m5D3 D/JjIscOfD/58Wg8Ozw6fXH34qv3v/vhxzc//fTy++8v378/evN6eXszvbqYXJxPLp5NLoGz 8eXp+PJkcnk8uTyaXBwQ++Pn+/nJIjueZSez6eX+01fPTn5/ffbuFrj+7s3rf/762z//0/d/ /fmHv/3L9bevd2+O+0c7ydNRtOyHi1xOIivhTd8qtNhrgRmXctwGLW6KHpkx0Gv74L4kx0Dg YE4FnIzW5TiCAWDGnUqOnXU5dmPtxqGH0lnKcZzDP2aVDJFNOca4plE38gmN0/hQBWouVfKL 5Th+QI6rLSjHcLPQZZAYLBqwkuMS7bshzpcCUHQiCpCTHPtJEiSpTjHiq7NhlI4McQoGPCRg ZVwAcpzAyjBJhiDHYMZmGYIWx0iY9EmXaRcVhksAcO50EIEul8NWJHgXQ7kxC6LUD1N4qVWA hXiFH3LyY8wM2ZBj/ejsvUchOX7QjIEq5F/FjGEdxLeg2Eu6SW+okeOqE+GnAI/5KWzcpZRj 48f4q2tgvkoxuPBjSgsxkM2XcW7sX4gvGuWruGtoD/w4xIgvB7AXOozBaw6O1m4YemHIIjhz oA/I5hO4DwxIJByreIgGeFkmUl4o3JC7moEQkwSDgtiOdtyQgBXtwE3a5To+DAMVFm4gXTy7 U7QibJ9ZyrNIjnvgxwSsdCV8S2GRRwy5sVaTtRoefGNtY8N5Z2sVOabiFeDHPdUECzQdj8MR i8YinkpQZCAkUSY5DuJCjqXJlNiQY5xOh5FgkGNM7TaQGXMyY3Bfl6hm05vuAxVleYp1OZYg x6mrUuPHnBAqlUjCZcJFbGAs8ljkkhxjosW6HHcFVh3u8KQD8lp32cf4qBzXBdooshlZl2OT esHjLo86PGwDrmqAGTtsC4xWJzaIbzYUg6k/20uPznZOzpcgx8+vDs+e7+2fTCdz+FfBw8xO +l5/LPOxSIcM5Tju+UaOsWaFoSN8S/iODFyhHCZsm6Mc92pyvNWjTN8NOaamdIUZ064qctxh HUv2bGU7WD/b4fBfB+R4AJJEpSpGkaZSFSKTHnx3hC640YYcd36xHGOLK5xFsyHHHhtwORL+ BJxVg8hGsyheJOTB96mbcVQ34EfAvh41OZaE0kaO4SNA5SlKOdZGjoOp9Cd1OcYEIV7KcS/q dciMm0EHcyONGfPGE779hG8RsIJy3FDtFshxVMpxf0OOpRgIlOOU8cQjWKHFKayAFjOZcYkN n2Fp5Fj6A0ly7AdUgwLluDRjMOB4EqU7icHIMegyyTHuhfF1KJCs4DHrfgxyjInmVKKkLsc4 +RLedwDezd9+/t5+jBzbtiNl2B9M9vYPLq6ef/Hm9t3XN++/fv727fGrV4urq9HZWf/kOD8+ zI8PgOx4Pz3ezY6X+clufgLLRX4y75/MYRk+HQW7A707gJvz66OjNxenb2/O3r64+ObVzXe/ e/nD27s//P76m9d7L07AjINZJqcxaLE/jflI92LWVDU5htMyOPhIjo0T/x/lmMx4U44llW4N cCIRziiKvJUc9wUI8Zoc95XGS9IbcqzCQOB8vlDd0xqgMJvPI8cA3iwDyetyXAO2UKUtAygy 3rGUY51mockSzoZhUhAnaMDECIV4BdwsdoEZkxz3Q9BiAtbNRiABjF6XW6phFVG8Gh/Vd0VZ oBO/9OPPJMcbZmwAA66ZJZrx/b2gmCaIi3IM7zKNrL/pj7GuuY+ycRTdu9emHK/dxUS4V39C 8QjFgEfaCgKo/pgfUtx9Y1jxspiw+qfJcXmgBgyvzCiaywJKQT0p0YAtB774Q8fBBCdawjqA fgwDmBNwJxBOIB1NXfq0tANuKdaTbk84dbrC6QirzbuYqcmoJn85RQa+rp4YP6b8ikKOnSdd 2WRRV6Q9P7f1wItGHPy46P88FZhosSnHlCyxIcdkxgrTi3Hqz3rM2JixcV9YqTtxxeNyjOnC binHFDZGM6a2bYkQcQELyY8peIxZFpty3AZ4gvJad9zH+KgcVwPqwOBKjqkJSDW3ryviNsCC psO3XLHNg7ZOQY5djApP1HQZ7x+Pj58tMHJ8eXB6vvv0aDLaCaPcCxIryp18JFCOKXIcJL0g RjkWQZspQ4errvFjJh2X2xZNyFvJsfWQHMN6Jabl9kKO7WbH6/R4F9N16KKEF3qlHIM2oRyH oxBuykyymLlhETv81eW4QWWA1+UYO8ZJOOkag7ZSveEdHc9j8OD7rMzYVGf7uB+bjnelHMPR PoXDWz4mx7ClcOgpyHrlx1wOGe+7Ro67YMZBYcagv1uSYsZY5Ljqk7eFNd1ECwaAQ6/J8fCe HPc5y0iFwYwNKUdPJcCM0YkrUI5NozssXQyCG45WZhyOAvBgcuIiZgxmHE/DUo6LMRWa5JhS kMGP8XfBb+Qp92IPi1v7Vrcmx+U/HCpO8tvP39uPSauwLItzlWbZbD4/Pjm4vDq9e3l4d7d7 fTU5O8sODvRyGSwX/nKuljO12JGLqViM5GKoliN/OQx2h3pvCFoM+ItczlIxS+P98fh8b+/u 7PDNxcmX12df3Z6/uzt/++Loi4vl9VF+uOPPUrvvO7nyBr4YaVh2Yrdh0ircpjFj4MNy3I2K nIpOgJ9Pk+b/QTmu2n19mhyHGfpx7aL//7scA+DELiivcd/KjGGFcEPtVbkWZMkfkGNKIy7y JUptHcbxaEXpxIa6GRvqvvthOd4waVrpw0YEBoAfh6mvE0kvNfYruZ9W8UvkGJzYsDEAw6gE 5Y7jFjJpg200MaKDBCwQJ0F+TI5hl/FUtOqiVPOHuX8UAcWBVAC/vTJUlGNzLwMK7or15/aI HKMZl08SgDHwCmwMwF2/ihyDVWCQ2C5s2Mhx5cePyrGwA2YptyudDrNWcLsjnLawQErAiQ1g J0aO6evqITnm227QIj+2/NzRfQ+7Z6EfY+Q4MpkVm3Js/JhaPRNkBlxSsgQ6cREYxmixyIFS dvvGjw2VGQMflOPCjz9JjnmMs/Q+nxzXY8bFrEECbtL2Ine5mNuXWdQ6pCeTLsB1y5PbTDVl 2IkykGPMIU6HfLgTLPf7h6ezs+dPn10eHD9b7h2OBtNAp9hEGjQ6HbJsxNKBizUrEkvHNmZW mAl5JudYdZmitGNuOcwy1SpIjlstp9WwyxoRH5NjgDIrsGBFj3V6oosZ7cJytSsy5fdN5Dg0 oBybahVGjgO7V/rxrynHolnLOXa8FDsqiyFXIMdYQcIHlwWpjTC/IgYbrgNbUHmx+gQWLf4c cowfCpJj8ylA6IPAB66X206GkakH5BjAOsdFnzyUY9lqBDU5zpk7EF5pxpUci74QOdgwRydO OYaKyYkNqK0VD8vxGtFYkxBXhAbw4xJtKBMt6n5cxI+9xIP/V7aGtx7PyYsOeYBJN3ca/wuy 3LE3KuHM/gAAAABJRU5ErkJggg== انت مدرك ليه كتب لك الاستاذ @ناقل فى الملاحظة فى مشاركته فى الرد عليكم : حجم البيانات المشفرة (Base64) يمكن أن يكون كبيرًا، مما يجعل QR Code أكثر تعقيدًا طيب وده اللى هيظهر عند المسح للكيو اركود للصورة : شفرة (Base64) اللى وضعت لك لها مثال ولاصارحك الرأى : هذا اصلا ان استطعت تحويل الشفرة هذه فقط الى رمز استجابه سريع هل انت مدرك لما سوف يحدث ؟ هل ما زلت تريد الاستمرار ؟

استاذي العزيز @سامي الحداد وهو المطلوب جزيل الشكر والامتنان

الله يبيض وجهك تظهر لي هذه عند الضغط على تنفيذ (لم يتم العثور على العمود B ) : وكتعديل على طريقة تحديد أسماء الأعمدة ، قمت بهذا التعديل الطفيف : والنتيجة ستكون حسب الإجابة على هذه الرسالة : وكذلك تم تعديل كود الكومبو الآخر أيضا 🙂 الأول: Private Sub Comb_Sheets_AfterUpdate() On Error GoTo ErrorHandler Dim col As Long If IsNull(Me.Comb_Sheets) Or Me.Comb_Sheets = "" Then Exit Sub Set xlWorksheet = xlWorkbook.Sheets(Me.Comb_Sheets.Value) Me.Comb_Cells.RowSource = "" Me.Comb_Cells = "" Dim HasColumnHead As Boolean HasColumnHead = True If MsgBox("هل الصف الأول هو عنوان الأعمدة؟", vbMsgBoxRight + vbYesNo, "") = vbNo Then HasColumnHead = False For col = 1 To xlWorksheet.UsedRange.Columns.Count If HasColumnHead = True Then ' To Fill Combobox with First row Names as column Name Me.Comb_Cells.AddItem xlWorksheet.Cells(1, col).Value Else ' Fill Combobox with column Names like A,B,C,....etc Me.Comb_Cells.AddItem Split(xlWorksheet.Cells(1, col).Address, "$")(1) End If Next col Exit Sub ErrorHandler: MsgBox "حدث خطأ: " & vbCrLf & Err.Description, vbCritical + vbMsgBoxRight, "" End Sub الثاني : Private Sub Comb_Sheet_AfterUpdate() On Error GoTo ErrorHandler Dim col As Long If IsNull(Me.Comb_Sheet) Then Exit Sub Set xlWorksheet = xlWorkbook.Sheets(Me.Comb_Sheet.Value) Me.Comb_Cell.RowSource = "" Me.Comb_Cell = "" Dim HasColumnHead As Boolean HasColumnHead = True If MsgBox("هل الصف الأول هو عنوان الأعمدة؟", vbMsgBoxRight + vbYesNo, "") = vbNo Then HasColumnHead = False For col = 1 To xlWorksheet.UsedRange.Columns.Count If HasColumnHead = True Then ' To Fill Combobox with First row Names as column Name Comb_Cell.AddItem xlWorksheet.Cells(1, col).Value Else ' Fill Combobox with column Names like A,B,C,....etc Me.Comb_Cell.AddItem Split(xlWorksheet.Cells(1, col).Address, "$")(1) End If Next col Exit Sub ErrorHandler: MsgBox "حدث خطأ: " & vbCrLf & Err.Description, vbCritical + vbMsgBoxRight, "" End Sub

وعليكم السلام تفضل أخي حسب ما فهمت Private Sub TXT_AfterUpdate() Dim FormName As String Dim RecordID As String Dim FilterCondition As String FormName = Me.TXT.Value RecordID = Me!ID.Value If Not IsNull(FormName) And Not IsNull(RecordID) Then FilterCondition = "[ID] = " & RecordID DoCmd.OpenForm FormName, , , FilterCondition Else MsgBox " .الرجاء تحديد النموذج والسجل لفتحه ", vbExclamation End If End Sub واليك الملف بالتوفيق فتح نموذج محدد من خلال نموذج فرعي.accdb

طبعاً نستطيع ذلك مهندسنا الغالي .. في الكومبوبوكس المخصص لاختيار الورقة ( Comb_Sheets و Comb_Sheet ) ,, ستلاحظ أن الكود بهذا الشكل :- في Comb_Sheets مثلاً .. Private Sub Comb_Sheets_AfterUpdate() On Error GoTo ErrorHandler Dim col As Long If IsNull(Me.Comb_Sheets) Or Me.Comb_Sheets = "" Then Exit Sub Set xlWorksheet = xlWorkbook.Sheets(Me.Comb_Sheets.Value) Me.Comb_Cells.RowSource = "" Me.Comb_Cells = "" For col = 1 To xlWorksheet.UsedRange.Columns.Count '---------------------------------------------- Me.Comb_Cells.AddItem xlWorksheet.Cells(1, col).Value '---------------------------------------------- Next col Exit Sub ErrorHandler: MsgBox "حدث خطأ: " & vbCrLf & Err.Description, vbCritical + vbMsgBoxRight, "" End Sub لاحظ السطر الموجود بين التعليقين . فقط سنستبدله بالسطر التالي :- Me.Comb_Cells.AddItem Split(xlWorksheet.Cells(1, col).Address, "$")(1) وكذلك الأمر بالنسبة للكومبوبوكس Comb_Sheet ، سيصبح التعديل بهذا الشكل .. Private Sub Comb_Sheet_AfterUpdate() On Error GoTo ErrorHandler Dim col As Long If IsNull(Me.Comb_Sheet) Then Exit Sub Set xlWorksheet = xlWorkbook.Sheets(Me.Comb_Sheet.Value) Me.Comb_Cell.RowSource = "" Me.Comb_Cell = "" For col = 1 To xlWorksheet.UsedRange.Columns.Count Me.Comb_Cell.AddItem Split(xlWorksheet.Cells(1, col).Address, "$")(1) '<<<<<<<<<< Next col Exit Sub ErrorHandler: MsgBox "حدث خطأ: " & vbCrLf & Err.Description, vbCritical + vbMsgBoxRight, "" End Sub أتمنى أن أكون قد وُفقت في الإجابة

جرب هذا Function record(Criteria As String) Dim rs As DAO.Recordset Dim db As DAO.Database Dim condition As String ' قم بتعيين قاعدة البيانات الحالية Set db = CurrentDb Set rs = db.OpenRecordset("SELECT * FROM customers") ' تحديد الشرط condition = "City = '" & Criteria & "'" rs.FindFirst condition Do While Not rs.NoMatch ' إضافة العنصر إلى القائمة List1.AddItem rs!FirstName ' ابحث عن العنصر التالي rs.FindNext condition Loop ' إغلاق السجل rs.Close Set rs = Nothing Set db = Nothing End Function Private Sub Command0_Click() Dim City As String ' تعيين القيمة للمدينة City = "aa" ' استدعاء الدالة record City End Sub

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا في Module ضع الكود التالي Sub ColoriageDoublons() Dim WSarr As Variant, couleurs As Long, d As Object, _ s As Variant, OnRng As Range, lastRow As Long, a, i As Long WSarr = Array(1, 2, 3): couleurs = RGB(0, 204, 255) Set d = CreateObject("Scripting.Dictionary") For Each s In WSarr With Sheets(s) lastRow = .Cells.Find(What:="*", LookIn:=xlValues, _ SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row a = .Range("C4:C" & lastRow).Value For i = 1 To UBound(a, 1) If a(i, 1) <> "" Then d(a(i, 1)) = d(a(i, 1)) + 1 Next i End With Next s For Each s In WSarr With Sheets(s) lastRow = .Cells.Find(What:="*", LookIn:=xlValues, _ SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row Set OnRng = .Range("C4:C" & lastRow) a = OnRng.Value For i = 1 To UBound(a, 1) OnRng.Cells(i).Interior.Color = IIf(a(i, 1) <> "" And d(a(i, 1)) > 1, couleurs, xlNone) Next i End With Next s End Sub وفي حدث ThisWorkbook Option Explicit Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) Dim WSarr As Variant WSarr = Array("1", "2", "3") If Not Intersect(Target, Sh.Columns("C")) Is Nothing And Target.Row >= 4 Then Application.ScreenUpdating = False If Not IsError(Application.Match(Sh.Name, WSarr, 0)) Then Call ColoriageDoublons End If Application.ScreenUpdating = True End If End Sub تلوين الخلايا v2 المكررة.xlsm

بارك الله فيك استاذ / محمد فى الحقيقة لا أدرى ماهى الطريقة الأمثل للحصول على الفرق بطريقة صحيحة 100% الناتج = 47 + 24 = 71 عن الشهور الناتج = 29 + 12 = 41 يوم ( 1 شهر + 11 يوم ) يعطى فى النهاية عدد الأيام والشهور عن المدة الأولى = 72 شهر و 11 يوم إذن هناك مطابقة وفقا للحل المقدم بمعرفتك سوف أختبر ذلك على العديد من التواريخ وسأخبرك إن كان هناك ملاحظات وشكرا لك على حسن الإستجابة وجزاكم الله خيرا

وعليكم السلام ورحمة الله تعالى وبركاته Sub SaveAsPDF() Const Max As Long = 1000 Dim WS As Worksheet, Irow As Long, OnRng As Range Dim xPath As String, Dossier As String, Fichier As String Set WS = Sheets("Sheet1") Irow = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row If Irow > Max Then Irow = Max: Set OnRng = WS.Range("A2:Z" & Irow) If Application.WorksheetFunction.CountA(OnRng) = 0 Then Exit Sub WS.ResetAllPageBreaks With WS.PageSetup .PrintArea = OnRng.Address: .Orientation = xlPortrait: .PaperSize = xlPaperA4 .Zoom = False: .FitToPagesWide = 1: .FitToPagesTall = False End With Dossier = ThisWorkbook.Path & "\ملفات PDF" If Dir(Dossier, vbDirectory) = "" Then MkDir Dossier Fichier = Replace(WS.Range("AA1").Value, "/", "_") xPath = Dossier & "\" & Fichier & " " & Format(Now, "yyyy-mm-dd hh.mm") & ".pdf" WS.ExportAsFixedFormat Type:=xlTypePDF, FileName:=xPath, _ Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False WS.PageSetup.PrintArea = "" MsgBox "تم حفظ الملف بنجاح ", vbInformation End Sub Test-PDF.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا حفظ الملفات في تفس مسار الملف Option Explicit Sub SAVE_PDF() Dim ScWS As Variant, Path As String, i As Integer ScWS = Array("Sheet1", "Sheet2", "Sheet3") Path = ThisWorkbook.Path & "\" If Path = "\" Then Exit Sub For i = LBound(ScWS) To UBound(ScWS) If Not ShExists(ScWS(i)) Then MsgBox "الورقة " & ScWS(i) & " غير موجودة": Exit Sub Application.ScreenUpdating = False On Error Resume Next Sheets(ScWS(i)).ExportAsFixedFormat Type:=xlTypePDF, FileName:=Path & ScWS(i) & ".pdf", _ Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False On Error GoTo 0 Next i Application.ScreenUpdating = True MsgBox "تم حفظ الملفات بنجاح" End Sub لإنشاء مجلد وحفظ الملفات بداخله Sub SAVE_PDF_Folder() Dim ScWS As Variant, Path As String, Dossier As String, i As Integer ScWS = Array("Sheet1", "Sheet2", "Sheet3") Path = ThisWorkbook.Path & "\" Dossier = "ملفات PDF" If Path = "\" Then Exit Sub If Dir(Path & Dossier, vbDirectory) = "" Then MkDir Path & Dossier Path = Path & Dossier & "\" For i = LBound(ScWS) To UBound(ScWS) If Not ShExists(ScWS(i)) Then MsgBox "الورقة " & ScWS(i) & " غير موجودة": Exit Sub Application.ScreenUpdating = False On Error Resume Next Sheets(ScWS(i)).ExportAsFixedFormat Type:=xlTypePDF, FileName:=Path & ScWS(i) & ".pdf", _ Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False On Error GoTo 0 Next i Application.ScreenUpdating = True MsgBox "تم حفظ الملفات بنجاح" End Sub Function ShExists(ByVal SheetName As String) As Boolean On Error Resume Next: ShExists = Not Sheets(SheetName) Is Nothing: On Error GoTo 0 End Function حفظ الملفات مستقلة بصيغة PDF.xlsb

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

نعم صحيح 100%

تحديث جديد للكود السابق الذى يقوم بمعالجة التواريخ غير المنظمة وتحويلها إلى تنسيق صالح Function RectifyDateFormat(inputString As String) As Variant ' تمكين معالجة الأخطاء On Error GoTo ErrorHandler ' إزالة الفراغات الزائدة من بداية ونهاية السلسلة inputString = Trim(inputString) ' استبدال الأرقام الهندية بالأرقام العربية Dim i As Integer For i = 1632 To 1641 inputString = Replace(inputString, ChrW(i), CStr(i - 1632)) Next i ' استبدال الرموز غير القياسية بواصلات Dim SymbolsToRemove As Variant SymbolsToRemove = Array("(", ")", "?", "*", " ", "!", "-", "#", "@", "+", "\", "/", "//", ".", "_", "--", "|", ",", Chr(227), Chr(34)) inputString = ReplaceSymbols(inputString, SymbolsToRemove) ' تنظيف الواصلات الزائدة inputString = CleanHyphens(inputString) ' تقسيم السلسلة إلى أجزاء التاريخ Dim strDateParts() As String strDateParts = Split(inputString, "-") ' التأكد من أن السلسلة تحتوي على ثلاثة أجزاء If UBound(strDateParts) <> 2 Then MsgBox "التنسيق غير صالح. يجب أن يحتوي التاريخ على ثلاثة أجزاء (يوم، شهر، سنة).", vbExclamation, "خطأ" RectifyDateFormat = Null Exit Function End If ' تعيين الأجزاء إلى متغيرات مع إزالة الفراغات الزائدة Dim strPartOne As String, strPartTwo As String, strPartThree As String strPartOne = Trim(strDateParts(0)): strPartTwo = Trim(strDateParts(1)): strPartThree = Trim(strDateParts(2)) ' التأكد من أن الأجزاء يمكن تحويلها إلى أرقام If Not IsNumeric(strPartOne) Or Not IsNumeric(strPartTwo) Or Not IsNumeric(strPartThree) Then MsgBox "التنسيق غير صالح. يجب أن تكون أجزاء التاريخ أرقامًا.", vbExclamation, "خطأ" RectifyDateFormat = Null Exit Function End If ' تحليل أجزاء التاريخ Dim intDay As Integer, intMonth As Integer, intYear As Integer AnalyzeDateParts strPartOne, strPartTwo, strPartThree, intDay, intMonth, intYear ' التحقق من صحة التاريخ If Not IsValidDate(intDay, intMonth, intYear) Then MsgBox "التاريخ غير صالح. يرجى التحقق من اليوم والشهر والسنة.", vbExclamation, "خطأ" RectifyDateFormat = Null Exit Function End If ' إنشاء التاريخ وتنسيقه RectifyDateFormat = Format(DateSerial(intYear, intMonth, intDay), "dd/mm/yyyy") Exit Function ErrorHandler: ' معالجة الأخطاء MsgBox "حدث خطأ أثناء معالجة التاريخ. يرجى التحقق من التنسيق المدخل.", vbExclamation, "خطأ" RectifyDateFormat = Null End Function '************************************************************************************************************************************* ' Function: ReplaceSymbols ' Purpose: استبدال الرموز غير القياسية بواصلات '************************************************************************************************************************************* Private Function ReplaceSymbols(inputString As String, SymbolsToRemove As Variant) As String Dim strSymbol As Variant For Each strSymbol In SymbolsToRemove If strSymbol <> "-" Then inputString = Replace(inputString, strSymbol, "-") End If Next strSymbol ReplaceSymbols = inputString End Function '************************************************************************************************************************************* ' Function: CleanHyphens ' Purpose: تنظيف الواصلات الزائدة '************************************************************************************************************************************* Private Function CleanHyphens(inputString As String) As String inputString = Trim(Replace(inputString, "--", "-")) Do While Left(inputString, 1) = "-" inputString = Mid(inputString, 2) Loop Do While Right(inputString, 1) = "-" inputString = Left(inputString, Len(inputString) - 1) Loop CleanHyphens = inputString End Function '************************************************************************************************************************************* ' Subroutine: AnalyzeDateParts ' Purpose: تحليل أجزاء التاريخ لتحديد اليوم والشهر والسنة '************************************************************************************************************************************* Private Sub AnalyzeDateParts(strPartOne As String, strPartTwo As String, strPartThree As String, _ ByRef intDay As Integer, ByRef intMonth As Integer, ByRef intYear As Integer) ' تحليل الأجزاء بناءً على الطول If Len(strPartOne) = 4 Then ' السنة أولاً (تنسيق: YYYY-MM-DD أو YYYY-DD-MM) intYear = CInt(strPartOne) If CInt(strPartTwo) > 12 Then ' تنسيق: YYYY-DD-MM intDay = CInt(strPartTwo) intMonth = CInt(strPartThree) Else ' تنسيق: YYYY-MM-DD intMonth = CInt(strPartTwo) intDay = CInt(strPartThree) End If ElseIf Len(strPartThree) = 4 Then ' السنة أخيراً (تنسيق: DD-MM-YYYY) intYear = CInt(strPartThree) intMonth = CInt(strPartTwo) intDay = CInt(strPartOne) ElseIf Len(strPartTwo) = 4 Then ' السنة في المنتصف (تنسيق: DD-YYYY-MM أو MM-YYYY-DD) intYear = CInt(strPartTwo) If CInt(strPartOne) > 12 Then intDay = CInt(strPartOne) intMonth = CInt(strPartThree) ElseIf CInt(strPartThree) > 12 Then intDay = CInt(strPartThree) intMonth = CInt(strPartOne) Else intDay = CInt(strPartOne) intMonth = CInt(strPartThree) End If Else ' جميع الأجزاء أرقام صغيرة (تنسيق: D-M-YY) intDay = CInt(strPartOne) intMonth = CInt(strPartTwo) intYear = CInt(strPartThree) ' معالجة السنوات المكونة من رقمين If intYear < 100 Then If intYear >= 50 Then intYear = intYear + 1900 Else intYear = intYear + 2000 End If End If End If End Sub '************************************************************************************************************************************* ' Function: IsValidDate ' Purpose: التحقق من صحة التاريخ '************************************************************************************************************************************* Private Function IsValidDate(intDay As Integer, intMonth As Integer, intYear As Integer) As Boolean ' التحقق من صحة اليوم والشهر والسنة If intMonth < 1 Or intMonth > 12 Then IsValidDate = False Exit Function End If If intDay < 1 Or intDay > 31 Then IsValidDate = False Exit Function End If If intYear < 1900 Or intYear > 2100 Then IsValidDate = False Exit Function End If ' التحقق من عدد الأيام في الشهر Dim intDaysInMonth As Integer intDaysInMonth = Day(DateSerial(intYear, intMonth + 1, 0)) If intDay > intDaysInMonth Then IsValidDate = False Exit Function End If IsValidDate = True End Function

اثراء للموضوع ومشاركة مع احبابى واساتذتى العظماء اليكم تجميعه بأهم دوال الوقت الوتاريخ مجمعة فى وحدة نمطية عامة واحدة Public Function IsValidDate(ByVal dtDate As Date) As Boolean ' الغرض: التحقق مما إذا كان التاريخ المقدم تاريخًا صالحًا. ' الوسائط: dtDate - التاريخ المطلوب التحقق منه. ' الإرجاع: True إذا كان التاريخ صالحًا؛ وإلا False. ' مثال الاستخدام: ' If IsValidDate(txtDate) Then ' ' قم بعمل شيء ما مع التاريخ الصالح ' End If On Error Resume Next IsValidDate = IsDate(dtDate) On Error GoTo 0 End Function '1 Function FormatDate(ByVal vDate As Variant) As String ' الغرض: إرجاع سلسلة نصية بتنسيق التاريخ المستخدم بشكل طبيعي في . ' JET SQL. ' الوسيط: قيمة تاريخ/وقت. ' ملاحظة: يتم إرجاع تنسيق التاريخ فقط إذا لم يكن هناك مكون وقت، أو تنسيق التاريخ/الوقت إذا كان موجودًا. ' ' مثال الاستخدام: ' a = DLookup("[some field]", "some table", "[id]=" & Me.ID & " And [Date_Field]=" & FormatDate(The_Date_Field)) If IsDate(vDate) Then If DateValue(vDate) = vDate Then FormatDate = Format$(vDate, "\#mm\/dd\/yyyy\#") Else FormatDate = Format$(vDate, "\#mm\/dd\/yyyy hh\:nn\:ss\#") End If End If End Function Function GetAmericanDateFormat(ByVal vDate As Variant) As Date ' الغرض: تنسيق قيمة التاريخ إلى التنسيق الأمريكي (MM-dd-yyyy). ' الوسيط: قيمة تاريخ/وقت أو قيمة فارغة/غير محددة. ' ملاحظة: يتم إرجاع التاريخ الحالي بتنسيق MM-dd-yyyy إذا كانت الوسيطة فارغة أو غير محددة. ' ' ' ' مثال الاستخدام: ' formattedDate = GetAmericanDateFormat(SomeDateField) If IsNull(vDate) Or vDate = vbNullString Or Len(vDate) = 0 Then GetAmericanDateFormat = Format(Date, "MM-dd-yyyy", vbUseSystem) ElseIf IsValidDate(vDate) Then GetAmericanDateFormat = Format(CDate(vDate), "MM-dd-yyyy", vbUseSystem) Else GetAmericanDateFormat = "" End If End Function Function GetDateInEuropeanFormat(ByVal vDate As Variant) As Date ' الغرض: تنسيق قيمة التاريخ إلى التنسيق الأوروبي (dd-MM-yyyy). ' الوسيط: قيمة تاريخ/وقت أو قيمة فارغة/غير محددة. ' ملاحظة: يتم إرجاع التاريخ الحالي بتنسيق dd-MM-yyyy إذا كانت الوسيطة فارغة أو غير محددة. ' ' مثال الاستخدام: ' formattedDate = GetDateInEuropeanFormat(SomeDateField) If IsNull(vDate) Or Len(vDate) = 0 Then GetDateInEuropeanFormat = Format(Date, "dd-MM-yyyy", vbUseSystem) ElseIf IsValidDate(vDate) Then GetDateInEuropeanFormat = Format(CDate(vDate), "dd-MM-yyyy", vbUseSystem) Else GetDateInEuropeanFormat = "" End If End Function '----------------------------End------------------------------------------------------------------------------------------- '2 Public Function ConvertDate(ByRef strInputDate As String, ByVal strConversionType As String) As String ' الغرض: تحويل التاريخ بين التنسيق الهجري والميلادي بناءً على نوع التحويل المحدد. ' الوسائط: strInputDate - التاريخ المراد تحويله كسلسلة نصية. ' strConversionType - نوع التحويل، "H" للتحويل من الهجري إلى الميلادي، "M" للتحويل من الميلادي إلى الهجري. ' ملاحظة: يتم تعديل التاريخ وفقًا لليوم التصحيحي من الجدول tblAdjustHjriDate. ' ' مثال الاستخدام: ' convertedDate = ConvertDate(txtHijriDate, "H") ' تحويل من الهجري إلى الميلادي ' convertedDate = ConvertDate(txtMiladyDate, "M") ' تحويل من الميلادي إلى الهجري Dim intCorrectionDay As Integer Dim intSavedCalendar As Integer Dim dtConvertedDate As Date Dim strFormattedDate As String On Error GoTo ErrorHandler ' الحصول على يوم التصحيح من الجدول intCorrectionDay = DLookup("[AdjustDay]", "tblAdjustHjriDate") ' التحقق من صحة التاريخ المدخل If IsValidDate(strInputDate) Then ' تعيين نوع التقويم وتحويل التاريخ بناءً على نوع التحويل If strConversionType = "M" Then ' الميلادي إلى الهجري strInputDate = Trim(Format(DateAdd("d", -intCorrectionDay, strInputDate), "dd/mm/yyyy")) intSavedCalendar = VBA.calendar VBA.calendar = 1 dtConvertedDate = CDate(strInputDate) VBA.calendar = intSavedCalendar Else ' الهجري إلى الميلادي strInputDate = Trim(Format(DateAdd("d", intCorrectionDay, strInputDate), "dd/mm/yyyy")) intSavedCalendar = VBA.calendar VBA.calendar = 0 dtConvertedDate = CDate(strInputDate) VBA.calendar = 1 End If ' تنسيق التاريخ المحول كسلسلة نصية strFormattedDate = Format(dtConvertedDate, "dd/mm/yyyy") ConvertDate = strFormattedDate Else ConvertDate = "" End If Exit Function ErrorHandler: If err.Number = 13 Then MsgBox "تنسيق تاريخ غير صالح. يرجى التحقق من البيانات المدخلة.", vbOKOnly + vbExclamation, "خطأ" Else MsgBox "حدث خطأ غير متوقع: " & err.Description, vbOKOnly + vbCritical, "خطأ" End If Exit Function End Function '----------------------------End------------------------------------------------------------------------------------------- '3 Public Function ConvertNumberToLocale(ByVal strNumber As String, ByVal strLocale As String) As String ' الغرض: تحويل الأرقام بين النظام العددي العربي والإنجليزي بناءً على اللغة المحددة. ' الوسائط: strNumber - السلسلة الرقمية المراد تحويلها. ' strLocale - نوع اللغة، "Ar" للأرقام العربية، "En" للأرقام الإنجليزية. ' ملاحظة: تقوم بتحويل الأرقام من العربية إلى الإنجليزية والعكس. ' ' مثال الاستخدام: ' txtNumberToArabic = ConvertNumberToLocale(txtNumber, "Ar") ' تحويل الأرقام الإنجليزية إلى عربية ' txtNumberToEnglish = ConvertNumberToLocale(txtNumber, "En") ' تحويل الأرقام العربية إلى إنجليزية Dim strConvertedNumber As String If strLocale = "Ar" Then ' تحويل الأرقام الإنجليزية إلى عربية strConvertedNumber = Replace(strNumber, ChrW(48), ChrW(1632)) ' 0 strConvertedNumber = Replace(strConvertedNumber, ChrW(49), ChrW(1633)) ' 1 strConvertedNumber = Replace(strConvertedNumber, ChrW(50), ChrW(1634)) ' 2 strConvertedNumber = Replace(strConvertedNumber, ChrW(51), ChrW(1635)) ' 3 strConvertedNumber = Replace(strConvertedNumber, ChrW(52), ChrW(1636)) ' 4 strConvertedNumber = Replace(strConvertedNumber, ChrW(53), ChrW(1637)) ' 5 strConvertedNumber = Replace(strConvertedNumber, ChrW(54), ChrW(1638)) ' 6 strConvertedNumber = Replace(strConvertedNumber, ChrW(55), ChrW(1639)) ' 7 strConvertedNumber = Replace(strConvertedNumber, ChrW(56), ChrW(1640)) ' 8 strConvertedNumber = Replace(strConvertedNumber, ChrW(57), ChrW(1641)) ' 9 ElseIf strLocale = "En" Then ' تحويل الأرقام العربية إلى إنجليزية strConvertedNumber = Replace(strNumber, ChrW(1632), ChrW(48)) ' 0 strConvertedNumber = Replace(strConvertedNumber, ChrW(1633), ChrW(49)) ' 1 strConvertedNumber = Replace(strConvertedNumber, ChrW(1634), ChrW(50)) ' 2 strConvertedNumber = Replace(strConvertedNumber, ChrW(1635), ChrW(51)) ' 3 strConvertedNumber = Replace(strConvertedNumber, ChrW(1636), ChrW(52)) ' 4 strConvertedNumber = Replace(strConvertedNumber, ChrW(1637), ChrW(53)) ' 5 strConvertedNumber = Replace(strConvertedNumber, ChrW(1638), ChrW(54)) ' 6 strConvertedNumber = Replace(strConvertedNumber, ChrW(1639), ChrW(55)) ' 7 strConvertedNumber = Replace(strConvertedNumber, ChrW(1640), ChrW(56)) ' 8 strConvertedNumber = Replace(strConvertedNumber, ChrW(1641), ChrW(57)) ' 9 End If ConvertNumberToLocale = strConvertedNumber End Function '----------------------------End------------------------------------------------------------------------------------------- '4 Public Function GetMonthName(ByVal dtDate As Date, ByVal strLocale As String) As String ' الغرض: إرجاع اسم الشهر بناءً على اللغة المحددة. ' الوسائط: dtDate - التاريخ الذي يتم استخراج اسم الشهر منه. ' strLocale - نوع اللغة لتحديد لغة اسم الشهر. ' "HJ" للهجري، "Ar" للعربية، "En" للإنجليزية، "EnShrt" للإنجليزية المختصرة، ' "Cpti" للقبطية، "Syr" للسريانية. ' الإرجاع: اسم الشهر باللغة المحددة. ' ' مثال الاستخدام: ' txtMonthNameHijri = GetMonthName(txtDate, "HJ") ' اسم الشهر الهجري ' txtMonthNameArabic = GetMonthName(txtDate, "Ar") ' اسم الشهر العربي ' txtMonthNameEnglish = GetMonthName(txtDate, "En") ' اسم الشهر الإنجليزي ' txtMonthNameEnglishShort = GetMonthName(txtDate, "EnShrt") ' اسم الشهر الإنجليزي المختصر ' txtMonthNameCoptic = GetMonthName(txtDate, "Cpti") ' اسم الشهر القبطي ' txtMonthNameSyriac = GetMonthName(txtDate, "Syr") ' اسم الشهر السرياني Dim strMonthName(12) As String ' التحقق من صحة اللغة المحددة If strLocale <> "HJ" And strLocale <> "Ar" And strLocale <> "En" And strLocale <> "EnShrt" And strLocale <> "Cpti" And strLocale <> "Syr" And strLocale <> "No" Then MsgBox "اللغة المحددة غير صالحة. يرجى استخدام 'HJ'، 'Ar'، 'En'، 'EnShrt'، 'Cpti'، 'Syr'، أو 'No'.", vbExclamation, "خطأ" Exit Function End If If IsValidDate(dtDate) Then ' تحديد أسماء الأشهر لكل لغة Select Case strLocale Case "HJ" ' أسماء الأشهر الهجرية strMonthName(1) = "محرم" strMonthName(2) = "صفر" strMonthName(3) = "ربيع الأول" strMonthName(4) = "ربيع الآخر" strMonthName(5) = "جمادى الأولى" strMonthName(6) = "جمادى الآخرة" strMonthName(7) = "رجب" strMonthName(8) = "شعبان" strMonthName(9) = "رمضان" strMonthName(10) = "شوال" strMonthName(11) = "ذو القعدة" strMonthName(12) = "ذو الحجة" Case "Ar" ' أسماء الأشهر العربية strMonthName(1) = "يناير" strMonthName(2) = "فبراير" strMonthName(3) = "مارس" strMonthName(4) = "أبريل" strMonthName(5) = "مايو" strMonthName(6) = "يونيو" strMonthName(7) = "يوليو" strMonthName(8) = "أغسطس" strMonthName(9) = "سبتمبر" strMonthName(10) = "أكتوبر" strMonthName(11) = "نوفمبر" strMonthName(12) = "ديسمبر" Case "En" ' أسماء الأشهر الإنجليزية strMonthName(1) = "January" strMonthName(2) = "February" strMonthName(3) = "March" strMonthName(4) = "April" strMonthName(5) = "May" strMonthName(6) = "June" strMonthName(7) = "July" strMonthName(8) = "August" strMonthName(9) = "September" strMonthName(10) = "October" strMonthName(11) = "November" strMonthName(12) = "December" Case "EnShrt" ' أسماء الأشهر الإنجليزية المختصرة strMonthName(1) = "Jan" strMonthName(2) = "Feb" strMonthName(3) = "Mar" strMonthName(4) = "Apr" strMonthName(5) = "May" strMonthName(6) = "Jun" strMonthName(7) = "Jul" strMonthName(8) = "Aug" strMonthName(9) = "Sep" strMonthName(10) = "Oct" strMonthName(11) = "Nov" strMonthName(12) = "Dec" Case "Cpti" ' أسماء الأشهر القبطية strMonthName(1) = "Thout" strMonthName(2) = "Paope" strMonthName(3) = "Hator" strMonthName(4) = "Kiahk" strMonthName(5) = "Tobi" strMonthName(6) = "Meshir" strMonthName(7) = "Paremhat" strMonthName(8) = "Paremhou" strMonthName(9) = "Pashons" strMonthName(10) = "Paoni" strMonthName(11) = "Epip" strMonthName(12) = "Nasi" Case "Syr" ' أسماء الأشهر السريانية strMonthName(1) = "Nisan" strMonthName(2) = "Iyar" strMonthName(3) = "Sivan" strMonthName(4) = "Tammuz" strMonthName(5) = "Ab" strMonthName(6) = "Elul" strMonthName(7) = "Tishri" strMonthName(8) = "Heshvan" strMonthName(9) = "Kislev" strMonthName(10) = "Tevet" strMonthName(11) = "Shevat" strMonthName(12) = "Adar" Case "No" ' أسماء الأشهر بالأرقام strMonthName(1) = "( 01 )" strMonthName(2) = "( 02 )" strMonthName(3) = "( 03 )" strMonthName(4) = "( 04 )" strMonthName(5) = "( 05 )" strMonthName(6) = "( 06 )" strMonthName(7) = "( 07 )" strMonthName(8) = "( 08 )" strMonthName(9) = "( 09 )" strMonthName(10) = "( 10 )" strMonthName(11) = "( 11 )" strMonthName(12) = "( 12 )" End Select ' إرجاع اسم الشهر للتاريخ المحدد GetMonthName = strMonthName(Month(dtDate)) Else ' إرجاع سلسلة فارغة إذا كان التاريخ غير صالح GetMonthName = "" End If End Function '----------------------------End------------------------------------------------------------------------------------------- '5 Public Function GetDayName(ByVal dtAnyDate As Date, ByVal strLng As String) As String ' الغرض: إرجاع اسم اليوم بناءً على التاريخ واللغة المحددة. ' الوسائط: dtAnyDate - التاريخ الذي يتم استخراج اسم اليوم منه. ' strLng - نوع اللغة لاسم اليوم: ' "Ar" للعربية، "En" للإنجليزية، "EnShrt" للإنجليزية المختصرة. ' الإرجاع: اسم اليوم باللغة المحددة. ' ' مثال الاستخدام: ' txtDayNameAR = DayName(txtDate, "Ar") ' اسم اليوم بالعربية ' txtDayNameEn = DayName(txtDate, "En") ' اسم اليوم بالإنجليزية ' txtDayNameEnShrt = DayName(txtDate, "EnShrt") ' اسم اليوم بالإنجليزية المختصرة Dim strSat As String Dim strSun As String Dim strMon As String Dim strTues As String Dim strWed As String Dim strThurs As String Dim strFri As String ' التحقق من أن dtAnyDate تاريخ صالح If Not IsDate(dtAnyDate) Then MsgBox "الإدخال ليس تاريخًا صالحًا. يرجى إدخال تاريخ صحيح.", vbExclamation, "تاريخ غير صالح" GetDayName = "تاريخ غير صالح" Exit Function End If ' التحقق من صحة اللغة المحددة If strLng <> "Ar" And strLng <> "En" And strLng <> "EnShrt" Then MsgBox "اللغة المحددة غير صالحة. يرجى استخدام 'Ar'، 'En'، أو 'EnShrt'.", vbExclamation, "خطأ" Exit Function End If ' تحديد أسماء الأيام بناءً على اللغة Select Case strLng Case "Ar" strSat = "السبت" strSun = "الأحد" strMon = "الاثنين" strTues = "الثلاثاء" strWed = "الأربعاء" strThurs = "الخميس" strFri = "الجمعة" Case "En" strSat = "Saturday" strSun = "Sunday" strMon = "Monday" strTues = "Tuesday" strWed = "Wednesday" strThurs = "Thursday" strFri = "Friday" Case "EnShrt" strSat = "Sat" strSun = "Sun" strMon = "Mon" strTues = "Tue" strWed = "Wed" strThurs = "Thu" strFri = "Fri" End Select ' إرجاع اسم اليوم بناءً على يوم الأسبوع للتاريخ المحدد GetDayName = Choose(Weekday(dtAnyDate), strSun, strMon, strTues, strWed, strThurs, strFri, strSat) End Function '----------------------------End------------------------------------------------------------------------------------------- '6 Public Function NumofDays(ByVal dtAnyDate As Date) As Integer ' الغرض: إرجاع عدد الأيام في شهر التاريخ المحدد. ' الوسائط: dtAnyDate - التاريخ الذي يتم استخراج عدد الأيام في شهره. ' الإرجاع: عدد الأيام في شهر التاريخ المحدد. ' ' مثال الاستخدام: ' txtNumofDaysMonth = NumofDays(txtDate) ' حساب آخر يوم في الشهر الحالي باستخدام الدالة DateSerial ' ثم إرجاع جزء اليوم من ذلك التاريخ، والذي يمثل العدد الإجمالي للأيام في ذلك الشهر. ' التحقق من أن dtAnyDate تاريخ صالح If Not IsDate(dtAnyDate) Then MsgBox "الإدخال ليس تاريخًا صالحًا. يرجى إدخال تاريخ صحيح.", vbExclamation, "تاريخ غير صالح" NumofDays = -1 ' إرجاع قيمة غير صالحة للإشارة إلى خطأ Exit Function End If NumofDays = Day(DateSerial(Year(dtAnyDate), Month(dtAnyDate) + 1, 0)) End Function '----------------------------End------------------------------------------------------------------------------------------- '7 Public Function GetLastDayInMonth(ByVal dtAnyDate As Date) As Date ' الغرض: إرجاع آخر يوم في شهر التاريخ المحدد. ' الوسائط: dtAnyDate - التاريخ الذي يتم استخراج آخر يوم في شهره. ' الإرجاع: آخر يوم في شهر التاريخ المحدد. ' ' مثال الاستخدام: ' txtLastDayInMonth = GetLastDayInMonth(txtDate) ' حساب آخر يوم في الشهر الحالي باستخدام الدالة DateSerial. ' تقوم هذه الدالة بإنشاء تاريخ مع السنة والشهر من التاريخ المحدد وتعيين اليوم إلى 0، ' مما يعطينا بشكل فعال آخر يوم في الشهر السابق، أي آخر يوم في الشهر الحالي. ' التحقق من أن dtAnyDate تاريخ صالح If Not IsDate(dtAnyDate) Then MsgBox "الإدخال ليس تاريخًا صالحًا. يرجى إدخال تاريخ صحيح.", vbExclamation, "تاريخ غير صالح" GetLastDayInMonth = CDate("0001-01-01") ' إرجاع تاريخ غير صالح للإشارة إلى خطأ Exit Function End If GetLastDayInMonth = DateSerial(Year(dtAnyDate), Month(dtAnyDate) + 1, 0) End Function '----------------------------End------------------------------------------------------------------------------------------- '8 Public Function GetFirstDayOfMonth(ByVal dtAnyDate As Date) As Date ' الغرض: إرجاع أول يوم في شهر التاريخ المحدد. ' الوسائط: dtAnyDate - التاريخ الذي يتم استخراج أول يوم في شهره. ' الإرجاع: أول يوم في شهر التاريخ المحدد. ' ' مثال الاستخدام: ' txtFirstDayOfMonth = GetFirstDayOfMonth(txtDate) ' التحقق من أن dtAnyDate تاريخ صالح If Not IsDate(dtAnyDate) Then MsgBox "الإدخال ليس تاريخًا صالحًا. يرجى إدخال تاريخ صحيح.", vbExclamation, "تاريخ غير صالح" GetFirstDayOfMonth = CDate("0001-01-01") ' إرجاع تاريخ غير صالح للإشارة إلى خطأ Exit Function End If ' حساب أول يوم في الشهر الحالي باستخدام الدالة DateSerial GetFirstDayOfMonth = DateSerial(Year(dtAnyDate), Month(dtAnyDate), 1) End Function '----------------------------End------------------------------------------------------------------------------------------- '9 Public Function GetFirstDayOfNextMonth(ByVal dtAnyDate As Date) As Date ' الغرض: إرجاع أول يوم في الشهر التالي للتاريخ المحدد. ' الوسائط: dtAnyDate - التاريخ الذي يتم استخراج أول يوم في الشهر التالي له. ' الإرجاع: أول يوم في الشهر التالي للتاريخ المحدد. ' ' مثال الاستخدام: ' txtFirstDayOfNextMonth = GetFirstDayOfNextMonth(txtDate) ' التحقق من أن dtAnyDate تاريخ صالح If Not IsDate(dtAnyDate) Then MsgBox "الإدخال ليس تاريخًا صالحًا. يرجى إدخال تاريخ صحيح.", vbExclamation, "تاريخ غير صالح" GetFirstDayOfNextMonth = CDate("0001-01-01") ' إرجاع تاريخ غير صالح للإشارة إلى خطأ Exit Function End If ' إرجاع أول يوم في الشهر التالي باستخدام الدالة DateSerial GetFirstDayOfNextMonth = DateSerial(Year(dtAnyDate), Month(dtAnyDate) + 1, 1) End Function '----------------------------End------------------------------------------------------------------------------------------- '10 Public Function GetFirstDayOfPreviousMonth(ByVal dtAnyDate As Date) As Date ' الغرض: إرجاع أول يوم في الشهر السابق للتاريخ المحدد. ' الوسائط: dtAnyDate - التاريخ الذي يتم استخراج أول يوم في الشهر السابق له. ' الإرجاع: أول يوم في الشهر السابق للتاريخ المحدد. ' ' مثال الاستخدام: ' txtFirstDayOfPreviousMonth = GetFirstDayOfPreviousMonth(txtDate) ' التحقق من أن dtAnyDate تاريخ صالح If Not IsDate(dtAnyDate) Then MsgBox "الإدخال ليس تاريخًا صالحًا. يرجى إدخال تاريخ صحيح.", vbExclamation, "تاريخ غير صالح" GetFirstDayOfPreviousMonth = CDate("0001-01-01") ' إرجاع تاريخ غير صالح للإشارة إلى خطأ Exit Function End If ' إرجاع أول يوم في الشهر السابق باستخدام الدالة DateSerial GetFirstDayOfPreviousMonth = DateSerial(Year(dtAnyDate), Month(dtAnyDate) - 1, 1) End Function '----------------------------End------------------------------------------------------------------------------------------- '11 Public Function GetLastDayOfMonth(ByVal dtAnyDate As Date) As Date ' الغرض: إرجاع آخر يوم في شهر التاريخ المحدد. ' الوسائط: dtAnyDate - التاريخ الذي يتم استخراج آخر يوم في شهره. ' الإرجاع: آخر يوم في شهر التاريخ المحدد. ' ' مثال الاستخدام: ' txtLastDayOfMonth = GetLastDayOfMonth(txtDate) ' التحقق من أن dtAnyDate تاريخ صالح If Not IsDate(dtAnyDate) Then MsgBox "الإدخال ليس تاريخًا صالحًا. يرجى إدخال تاريخ صحيح.", vbExclamation, "تاريخ غير صالح" GetLastDayOfMonth = CDate("0001-01-01") ' إرجاع تاريخ غير صالح للإشارة إلى خطأ Exit Function End If ' إرجاع آخر يوم في الشهر باستخدام الدالة DateSerial GetLastDayOfMonth = DateSerial(Year(dtAnyDate), Month(dtAnyDate) + 1, 0) End Function '----------------------------End------------------------------------------------------------------------------------------- '12 Public Function GetLastDayOfNextMonth(ByVal dtAnyDate As Date) As Date ' الغرض: إرجاع آخر يوم في الشهر التالي للتاريخ المحدد. ' الوسائط: dtAnyDate - التاريخ الذي يتم استخراج آخر يوم في الشهر التالي له. ' الإرجاع: آخر يوم في الشهر التالي للتاريخ المحدد. ' ' مثال الاستخدام: ' txtLastDayOfNextMonth = GetLastDayOfNextMonth(txtDate) ' التحقق من أن dtAnyDate تاريخ صالح If Not IsDate(dtAnyDate) Then MsgBox "الإدخال ليس تاريخًا صالحًا. يرجى إدخال تاريخ صحيح.", vbExclamation, "تاريخ غير صالح" GetLastDayOfNextMonth = CDate("0001-01-01") ' إرجاع تاريخ غير صالح للإشارة إلى خطأ Exit Function End If ' إرجاع آخر يوم في الشهر التالي باستخدام الدالة DateSerial GetLastDayOfNextMonth = DateSerial(Year(dtAnyDate), Month(dtAnyDate) + 2, 0) End Function '----------------------------End------------------------------------------------------------------------------------------- '13 Public Function GetLastDayOfPreviousMonth(ByVal dtAnyDate As Date) As Date ' الغرض: إرجاع آخر يوم في الشهر السابق للتاريخ المحدد. ' الوسائط: dtAnyDate - التاريخ الذي يتم استخراج آخر يوم في الشهر السابق له. ' الإرجاع: آخر يوم في الشهر السابق للتاريخ المحدد. ' ' مثال الاستخدام: ' txtLastDayOfPreviousMonth = GetLastDayOfPreviousMonth(txtDate) ' التحقق من أن dtAnyDate تاريخ صالح If Not IsDate(dtAnyDate) Then MsgBox "الإدخال ليس تاريخًا صالحًا. يرجى إدخال تاريخ صحيح.", vbExclamation, "تاريخ غير صالح" GetLastDayOfPreviousMonth = CDate("0001-01-01") ' إرجاع تاريخ غير صالح للإشارة إلى خطأ Exit Function End If ' إرجاع آخر يوم في الشهر السابق باستخدام الدالة DateSerial GetLastDayOfPreviousMonth = DateSerial(Year(dtAnyDate), Month(dtAnyDate), 0) End Function '----------------------------End------------------------------------------------------------------------------------------- '14 Public Function TimeByLanguage(ByVal dtAnyDate As Variant, ByVal strLng As String) As String ' الغرض: إرجاع الوقت بتنسيق اللغة المحددة. ' الوسائط: dtAnyDate - التاريخ/الوقت الذي يتم تنسيقه. ' strLng - اللغة المحددة لتنسيق الوقت ("Ar" للعربية، "En" للإنجليزية). ' الإرجاع: الوقت بتنسيق اللغة المحددة. ' ' مثال الاستخدام: ' txtTimeArabic = TimeByLanguage(txtDateTime, "Ar") ' الوقت بالعربية ' txtTimeEnglish = TimeByLanguage(txtDateTime, "En") ' الوقت بالإنجليزية ' التحقق من أن dtAnyDate تاريخ/وقت صالح If Not IsDate(dtAnyDate) Then MsgBox "الإدخال ليس تاريخًا/وقتًا صالحًا. يرجى إدخال تاريخ/وقت صحيح.", vbExclamation, "تاريخ/وقت غير صالح" TimeByLanguage = "تاريخ/وقت غير صالح" Exit Function End If ' تعريف نصوص AM وPM للغة العربية Dim strAm As String: strAm = "صباحًا " Dim strPm As String: strPm = "مساءً " ' تنسيق الوقت بناءً على اللغة المحددة Select Case strLng Case "Ar" ' تحويل الوقت إلى العربية واستبدال AM/PM بالنصوص العربية TimeByLanguage = ConvertNumberToLocale(Replace(Replace(Format(dtAnyDate, "hh:nn:ss AM/PM"), "AM", strAm), "PM", strPm), "Ar") Case "En" ' تحويل الوقت إلى الإنجليزية واستبدال النصوص العربية بـ AM/PM TimeByLanguage = ConvertNumberToLocale(Replace(Replace(Format(dtAnyDate, "hh:nn:ss AM/PM"), strAm, "AM"), strPm, "PM"), "En") Case Else ' إرجاع رسالة خطأ إذا كانت اللغة غير مدعومة TimeByLanguage = "اللغة غير مدعومة" End Select End Function '----------------------------End------------------------------------------------------------------------------------------- '15 Public Function GetLocalizedTimeString(ByVal strLng As String) As String ' الغرض: إرجاع الوقت الحالي بتنسيق اللغة المحددة. ' الوسائط: strLng - اللغة المحددة لتنسيق الوقت ("Ar" للعربية، "En" للإنجليزية). ' الإرجاع: الوقت الحالي بتنسيق اللغة المحددة. ' ' مثال الاستخدام: ' txtTimeArabic = GetLocalizedTimeString("Ar") ' الوقت الحالي بالعربية ' txtTimeEnglish = GetLocalizedTimeString("En") ' الوقت الحالي بالإنجليزية ' تعريف نصوص AM وPM للغة العربية Dim strAm As String: strAm = "صباحًا " Dim strPm As String: strPm = "مساءً " ' تنسيق الوقت بناءً على اللغة المحددة Select Case strLng Case "Ar" ' تحويل الوقت الحالي إلى العربية واستبدال AM/PM بالنصوص العربية GetLocalizedTimeString = ConvertNumberToLocale(Replace(Replace(Format(Now(), "hh:nn:ss AM/PM"), "AM", strAm), "PM", strPm), "Ar") Case "En" ' تحويل الوقت الحالي إلى الإنجليزية واستبدال النصوص العربية بـ AM/PM GetLocalizedTimeString = ConvertNumberToLocale(Replace(Replace(Format(Now(), "hh:nn:ss AM/PM"), strAm, "AM"), strPm, "PM"), "En") Case Else ' إرجاع رسالة خطأ إذا كانت اللغة غير مدعومة GetLocalizedTimeString = "اللغة غير مدعومة" End Select End Function '----------------------------End------------------------------------------------------------------------------------------- '16 Public Function FormatDateByLanguage(ByVal dtAnyDate As Variant, ByVal strLng As String) As String ' الغرض: إرجاع التاريخ بتنسيق اللغة المحددة. ' الوسائط: dtAnyDate - التاريخ الذي يتم تنسيقه. ' strLng - اللغة المحددة لتنسيق التاريخ ("Ar" للعربية، "En" للإنجليزية). ' الإرجاع: التاريخ بتنسيق اللغة المحددة. ' ' مثال الاستخدام: ' txtDateArabic = FormatDateByLanguage(txtDate, "Ar") ' التاريخ بالعربية ' txtDateEnglish = FormatDateByLanguage(txtDate, "En") ' التاريخ بالإنجليزية ' التحقق من أن dtAnyDate تاريخ صالح If Not IsDate(dtAnyDate) Then MsgBox "الإدخال ليس تاريخًا صالحًا. يرجى إدخال تاريخ صحيح.", vbExclamation, "تاريخ غير صالح" FormatDateByLanguage = "تاريخ غير صالح" Exit Function End If ' تنسيق التاريخ بناءً على اللغة المحددة Select Case strLng Case "Ar" ' تحويل التاريخ إلى العربية وإضافة رمز "م" (لتحديد التقويم الميلادي) FormatDateByLanguage = ConvertNumberToLocale(Format(dtAnyDate, "dd\/mm\/yyyy") & Space(2) & "م ", "Ar") Case "En" ' تحويل التاريخ إلى الإنجليزية وإضافة رمز "هـ" (لتحديد التقويم الهجري) FormatDateByLanguage = ConvertNumberToLocale(Format(dtAnyDate, "dd\/mm\/yyyy") & Space(2) & "هـ ", "En") Case Else ' إرجاع رسالة خطأ إذا كانت اللغة غير مدعومة FormatDateByLanguage = "اللغة غير مدعومة" End Select End Function '----------------------------End------------------------------------------------------------------------------------------- Public Function GetFirstDayOfYear(Optional ReferenceYear As Integer = 0) As Date ' الغرض: إرجاع أول يوم في السنة المحددة. ' الوسائط: ReferenceYear - السنة المرجعية (اختياري، إذا لم يتم تحديدها، يتم استخدام السنة الحالية). ' الإرجاع: أول يوم في السنة المحددة (1 يناير). ' ' مثال الاستخدام: ' txtFirstDayOfYear = GetFirstDayOfYear(2023) ' أول يوم في سنة 2023 ' txtFirstDayOfYear = GetFirstDayOfYear() ' أول يوم في السنة الحالية ' تحديد السنة المرجعية If ReferenceYear = 0 Then ReferenceYear = Year(Now) ' استخدام السنة الحالية إذا لم يتم تحديد سنة مرجعية End If ' إرجاع أول يوم في السنة (1 يناير) GetFirstDayOfYear = DateSerial(ReferenceYear, 1, 1) End Function '----------------------------End------------------------------------------------------------------------------------------- Public Function GetLastDayOfYear(Optional ReferenceYear As Integer = 0) As Date ' الغرض: إرجاع آخر يوم في السنة المحددة. ' الوسائط: ReferenceYear - السنة المرجعية (اختياري، إذا لم يتم تحديدها، يتم استخدام السنة الحالية). ' الإرجاع: آخر يوم في السنة المحددة (31 ديسمبر). ' ' مثال الاستخدام: ' txtLastDayOfYear = GetLastDayOfYear(2023) ' آخر يوم في سنة 2023 ' txtLastDayOfYear = GetLastDayOfYear() ' آخر يوم في السنة الحالية ' تحديد السنة المرجعية If ReferenceYear = 0 Then ReferenceYear = Year(Now) ' استخدام السنة الحالية إذا لم يتم تحديد سنة مرجعية End If ' إرجاع آخر يوم في السنة (31 ديسمبر) GetLastDayOfYear = DateSerial(ReferenceYear, 12, 31) End Function '----------------------------End------------------------------------------------------------------------------------------- ' حساب الفرق بين تاريخين (بالأيام، الأشهر، السنوات) Public Function GetDateDifferenceInDays(ByVal dtStartDate As Date, ByVal dtEndDate As Date) As Long ' الغرض: حساب الفرق بين تاريخين بالأيام. GetDateDifferenceInDays = DateDiff("d", dtStartDate, dtEndDate) End Function Public Function GetDateDifferenceInMonths(ByVal dtStartDate As Date, ByVal dtEndDate As Date) As Long ' الغرض: حساب الفرق بين تاريخين بالأشهر. GetDateDifferenceInMonths = DateDiff("m", dtStartDate, dtEndDate) End Function Public Function GetDateDifferenceInYears(ByVal dtStartDate As Date, ByVal dtEndDate As Date) As Long ' الغرض: حساب الفرق بين تاريخين بالسنوات. GetDateDifferenceInYears = DateDiff("yyyy", dtStartDate, dtEndDate) End Function '----------------------------End------------------------------------------------------------------------------------------- ' إضافة أو طرح أيام/أشهر/سنوات من تاريخ معين Public Function AddDaysToDate(ByVal dtDate As Date, ByVal intDays As Integer) As Date ' الغرض: إضافة أو طرح عدد محدد من الأيام من تاريخ معين. AddDaysToDate = DateAdd("d", intDays, dtDate) End Function Public Function AddMonthsToDate(ByVal dtDate As Date, ByVal intMonths As Integer) As Date ' الغرض: إضافة أو طرح عدد محدد من الأشهر من تاريخ معين. AddMonthsToDate = DateAdd("m", intMonths, dtDate) End Function Public Function AddYearsToDate(ByVal dtDate As Date, ByVal intYears As Integer) As Date ' الغرض: إضافة أو طرح عدد محدد من السنوات من تاريخ معين. AddYearsToDate = DateAdd("yyyy", intYears, dtDate) End Function '----------------------------End------------------------------------------------------------------------------------------- ' التحقق مما إذا كان تاريخ معين ضمن نطاق تاريخين Public Function IsDateInRange(ByVal dtDate As Date, ByVal dtStartDate As Date, ByVal dtEndDate As Date) As Boolean ' الغرض: التحقق مما إذا كان تاريخ معين يقع بين تاريخين محددين. IsDateInRange = (dtDate >= dtStartDate And dtDate <= dtEndDate) End Function '----------------------------End------------------------------------------------------------------------------------------- ' حساب العمر بناءً على تاريخ الميلاد Public Function CalculateAge(ByVal dtBirthDate As Date) As Integer ' الغرض: حساب العمر بالسنوات بناءً على تاريخ الميلاد. CalculateAge = DateDiff("yyyy", dtBirthDate, Now) If DateSerial(Year(Now), Month(dtBirthDate), Day(dtBirthDate)) > Now Then CalculateAge = CalculateAge - 1 End If End Function '----------------------------End------------------------------------------------------------------------------------------- ' تحديد عدد الأيام منذ تاريخ معين Public Function GetDaysSinceDate(ByVal dtStartDate As Date) As Integer ' الغرض: حساب عدد الأيام المنقضية منذ تاريخ معين. GetDaysSinceDate = DateDiff("d", dtStartDate, Now) End Function '----------------------------End-------------------------------------------------------------------------------------------

السلام عليكم ورحمة الله وبركاته بعد إذن اخى واستاذى الفاضل / عبد الله بشير أعتقد ان الموضوع ليس بحاجة الى مرفق للعمل عليه فقد أوفيت وهذة مشاركة بسيطة للإفادة وبطريقة أخرى Sub test() Dim i As Long, lr As Long, ocol Dim ws1 As Worksheet, ws2 As Worksheet ocol = Array(1, 13, 14, 15, 24, 26, 27, 31, 32, 36, 47, 48) Set ws1 = Sheets("تسجيل بيانات") Set ws2 = Sheets("الرئيسية") Application.ScreenUpdating = False With ws1 lr = .Cells(Rows.Count, "A").End(xlUp).Row For i = 0 To 11 .Cells(1, i + 1).Resize(lr, 1).Copy ws2.Cells(1, ocol(i)) Next i End With Application.ScreenUpdating = False End Sub شكرا وجزاكم الله خيرا

هذا كلام الذكاء الاصطناعي ... ولم اجربه نعم، يمكن استخدام VBA (Visual Basic for Applications) في Access لإنشاء QR Code يحتوي على بيانات صورة مشفرة (مثل صيغة Base64). ومع ذلك، لأن VBA لا يحتوي على مكتبة مدمجة لتوليد QR Codes، ستحتاج إلى مكتبة خارجية لتوليد الأكواد مثل zxing أو QR Code ActiveX Control. خطوات إنشاء QR Code باستخدام VBA: 1. تحويل الصورة إلى Base64 باستخدام VBA: يمكنك تحويل الصورة إلى نص Base64 داخل VBA باستخدام مكتبة مثل Microsoft XML 6.0. Function ConvertImageToBase64(filePath As String) As String Dim objStream As Object Dim objEncoder As Object ' فتح الصورة كـ Binary Set objStream = CreateObject("ADODB.Stream") objStream.Type = 1 ' Binary objStream.Open objStream.LoadFromFile filePath ' تحويل الصورة إلى Base64 Set objEncoder = CreateObject("MSXml2.DOMDocument").createElement("b64") objEncoder.DataType = "bin.base64" objEncoder.NodeTypedValue = objStream.Read ConvertImageToBase64 = objEncoder.Text ' تنظيف الكائنات objStream.Close Set objStream = Nothing Set objEncoder = Nothing End Function 2. إنشاء QR Code باستخدام مكتبة خارجية: يمكنك استخدام مكتبة QR Code جاهزة مثل QR Code ActiveX Control أو zxing. أضف المكتبة إلى مشروع Access الخاص بك. مثال لإنشاء QR Code Sub GenerateQRCode(base64Data As String, outputPath As String) Dim qrControl As Object ' إنشاء كائن QR Code من المكتبة الخارجية Set qrControl = CreateObject("YourQRCodeLibrary.QRCode") ' إدخال بيانات الصورة بصيغة Base64 qrControl.Text = base64Data ' حفظ الكود كصورة qrControl.SaveAsImage outputPath ' تنظيف الكائنات Set qrControl = Nothing End Sub 3. دمج الخطوات: قم بقراءة الصورة وتحويلها إلى Base64 باستخدام ConvertImageToBase64. استخدم النص المشفر لتوليد QR Code باستخدام GenerateQRCode. ملاحظات: تأكد من تثبيت المكتبة اللازمة لتوليد QR Code. حجم البيانات المشفرة (Base64) يمكن أن يكون كبيرًا، مما يجعل QR Code أكثر تعقيدًا. يُفضل تقليل حجم الصور المضغوطة قبل البدء.

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