كل الانشطه

لمحة عن التحديث الجديد 😁

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

أخي الفاضل الكريم ( أبو خليل ) بعد سلام الله عليكم ورحمة الله وبركاته في الملف المرفق في نتيجة الدور الثاني بالصف الثالث بعد رصد الدرجات فيه بنت اسمها ( اسينات محمد شعبان ) كان لها دور ثان في اللغة العربية وغابت في الدور الثاني ووضعت لها (0 ) ولم تظهر في نتيجة الدور الثاني . فلماذا ؟Data126.rar Data126.rar

هذا لا شك فيه ، وهو فعلاً ما يتم 😇

؟! تمة التجربة مرفق يأخذ العربي فقط استخدمة المرفق لعرض معاينة التقرير في النموذج يتحجم ويتغير طبقا للكود فقط هل لديك دالة تقسم بعد الاستعلام او الفلترة الى فلترة لعرض السجلات في التقرير وتعلم ان التقرير لحد معين من السجلات يمكن يعرضها او ينهار ويغلق ؟! , فنقسم كل 5000 الف سجل هل المعلومة صحيحة وهل لديك دالة استاذ @ابو جودي ❤️🌹☕ \ نستفيد من عصير خبرتك 😇 تحميل المرفق https://www.mediafire.com/file/0j7r9h3j0bk8rkw/Report_after_print_In_Form_with_tools_V1.mp4/file

النسخة 32 بت يجب ان يتم تحزيمها على اكسس 32 بت ومثلها 64 يجب ان تحزم على نسخة64 هذا كل شيء

أخي محمد المنتدى مليء بالكنوز و ملفات يمكن التعديل عليها بسهولة. مرفق ملف للاستاذ الكبير/ كيماس مع الاستعانة ببعض الأكواد للعلامة خبور. فقط ابحث عن أعمال هؤلاء الأساتذة و غيرهم الكثير مما لا تسعنى الذاكرة لذكرهم سترى و كأنك دخلت مغارة علي بابا. الملف المرفق به فورم مطاطي أي أنك فقط تكتب رؤوس الأعمدة بالعدد الذي تريده و تكتب البيانات و ستجد الفورم تلقائيا مطابق لما كتبته. أتمنى أن نسترجع هذه الملفات و نضيف عليها بعض اللمسات الحديثة وفقا لتطور برنامج الاكسيل و استحداث معادلات جديدة الديناميكى التام لاستعراض السجل وحفظ التغييرات مع الفريمkemas.xlsm

الاساتذة الكرام لي طلب عند حضراتكم لو امكن توفيره اكن ممنون لحضراتكم اريد ملف مخازن بس يكون الصرف منه الوارداولا يصدر اولا بسعره وعند نفاذ الكميه بسعرها يتم الصرف من الكميات بالسعر الذي تم الشراء به مثلا لو عندي بضاعه من اول الشهر بسعر 1 جنيه ولتكن الكميه 100 ثم تم شراء جديد 100 بسعر2ج مثلا وانا بعت 150 عايز احسب ال100 بال سعر القديم1 و ال 50 بسعر 2ج ولكم مني كل الاحترام

سأحاول تثبيت نسخة أوفيس 2003 وتجربة حفظ نسخة خاصة منه مع التعديل على الأكواد لتتوافق معه 😅 ، وربنا يستر تحديث جديد إن شاء الله قريباً

هذا طبيعي حاجة متعودين عليها من اكسس .. خاصة 2010 اما اصدار 2003 وتحزيم الملف mde فلم اواجه اي مشكلة خلال سنوات حيث تعمل على جميع اصدارات اكسس الحديثة بكل اريحية وبدون مشاكل 1- تحديثات ميكروسوفت على اصدارة اكسس لها تأثير لا شك 2- اعدادات وندوز الاقليمية عن نفسي بعد تحولي الى 2010 .. اذا لم يعمل الملف على الحاسبة البعيدة احاول الدخول عليها عن بعد وتنصيب نسخة اكسس التي اعمل عليها

وعليكم السلام ورحمة الله وبركاته .. معلمنا الجليل والفاضل .. أنا متفاجئ من هذه العقبات التي تظهر عند محاولتك تجربة الملفات التي أقوم برفعها بصيغة ACCDE ، رغم أني خشيت من رفع الصورة التالية لنفس الملف الذي تم رفعه في المشاركة - وملاحظتي انه يعمل دون مشاكل 😢 . سأحاول في التحديث التالي التحقق بشكل أكثر من طريقة حفظ الملف الى accde .. وأعتذر عن هذه المشكلة التي صادفتها 😇

تحديث لتجربة معالجة 'على سبيل المثال عند الكود او الدالة Call OptimizeStart { Coding }}; Call OptimizeEnd Option Compare Database Option Explicit Dim ixx As Integer, j As Integer, J1 As Integer ' تعريف المتغير العام لتخزين حالات الاتصال Public GlobalSavedLinks As Collection ' تحرير الذاكرة باستخدام API Private Declare PtrSafe Sub EmptyWorkingSet Lib "psapi" (ByVal hProcess As LongPtr) #If VBA7 And Win64 Then Private Declare PtrSafe Function GetCurrentProcess Lib "kernel32" () As LongPtr Private Declare PtrSafe Function SetProcessWorkingSetSize Lib "kernel32" (ByVal hProcess As LongPtr, ByVal dwMinimumWorkingSetSize As Long, ByVal dwMaximumWorkingSetSize As Long) As Long #Else Private Declare Function GetCurrentProcess Lib "kernel32" () As Long Private Declare Function SetProcessWorkingSetSize Lib "kernel32" (ByVal hProcess As Long, ByVal dwMinimumWorkingSetSize As Long, ByVal dwMaximumWorkingSetSize As Long) As Long #End If ' في قسم التصريحات العامة للوحدة النمطية #If VBA7 Then Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) #Else Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) #End If Private Sub PauseForUIUpdate(Optional ms As Long = 50) DoEvents Sleep ms DoEvents End Sub Private Sub OptimizeStart() On Error Resume Next ' 1. إيقاف تحديثات واجهة المستخدم Application.Echo False DoCmd.Hourglass True ' عرض مؤشر الانتظار ' 2. إيقاف التحذيرات والرسائل DoCmd.SetWarnings False ' 3. تحسين إعدادات العرض Application.SetOption "Show Status Bar", False Application.SetOption "Show Animations", False ' 4. تعطيل الأحداث المؤقتة للنموذج ' Me.Painting = False ' Me.FastLaserPrinting = True ' Me.ScrollBars = 0 ' تعطيل أشرطة التمرير مؤقتاً ' 5. تحرير الذاكرة Call ClearMemory ' 6. تعطيل تحديث الشاشة للنموذج Me.Repaint End Sub Private Sub OptimizeEnd() On Error Resume Next ' 1. إعادة تفعيل تحديثات واجهة المستخدم Application.Echo True DoCmd.Hourglass False ' 2. إعادة تفعيل التحذيرات DoCmd.SetWarnings True ' 3. استعادة إعدادات العرض Application.SetOption "Show Status Bar", True Application.SetOption "Show Animations", True ' 4. إعادة تفعيل خصائص النموذج ' Me.Painting = True ' Me.FastLaserPrinting = False ' Me.ScrollBars = 2 ' أشرطة التمرير الرأسية ' 5. تحديث النموذج Me.Refresh DoEvents End Sub Private Sub ClearMemory() On Error Resume Next ' طريقة بديلة لتحرير الذاكرة بدون استخدام API Dim db As DAO.Database Set db = CurrentDb ' تحرير ذاكرة الاستعلامات Dim qdf As DAO.QueryDef For Each qdf In db.QueryDefs qdf.Parameters.Refresh Next qdf ' إغلاق كائنات قاعدة البيانات Set qdf = Nothing Set db = Nothing ' تحرير ذاكرة النماذج المفتوحة Dim frm As Form For Each frm In Forms frm.Repaint Next frm End Sub ' دالة مساعدة للتحقق من دعم الخاصية Private Function IsPropertySupported(obj As Object, propName As String) As Boolean On Error Resume Next Dim testVal testVal = CallByName(obj, propName, VbGet) IsPropertySupported = (Err.Number = 0) Err.Clear End Function Private Sub ProcessInChunks() Dim i As Long Dim totalRecords As Long Dim chunkSize As Long totalRecords = 1000 ' عدد السجلات الكلي chunkSize = 100 ' حجم كل جزء Call OptimizeStart For i = 0 To totalRecords Step chunkSize ' معالجة جزء من البيانات ProcessChunk i, i + chunkSize ' تحديث الشاشة بين الحين والآخر If i Mod 200 = 0 Then Me.Repaint DoEvents End If Next i Call OptimizeEnd End Sub Sub ClearMemoryCache() ' محاولة لتحرير الذاكرة Dim i As Long For i = 1 To 100000 ' عملية فارغة لتحفيز تنظيف الذاكرة Next i ' طريقة أخرى لتحرير الذاكرة #If VBA7 And Win64 Then Call SetProcessWorkingSetSize(GetCurrentProcess(), -1, -1) #Else Call SetProcessWorkingSetSize(GetCurrentProcess(), -1, -1) #End If End Sub 1- يجب وضع اختصار سطح المكتب ثم تنقل لاي مكان مع تحديد الخصائص الاختصار الثاني انزال النافذه 2- استكمال انتقال بين القواعد واعادة قائمة المنسدلة .RowSouros 😇 3- والعملية بداية الكود ونهايتة تكون لاكود براميتر او لعدة عمليات استعلام وفلترة وتعديل احجام الادوات تستعمل او ان يكون اجراء المطول 4- انظر لتجربة اسرع تحميل المرفق https://www.mediafire.com/file/1n73xsnmz1l0yk8/Fix_Update_2_Miluon_Record_IN_One_Speed_Read_db_Caption_Filter.rar/file يجب اختيار زر انشاء عشر جداول ثم زر الاتصال ثم زر اضافة بيانات وهمية ثم التشغيل😇 للتجرب الى تحديث التالي مع المعالجة

هدية مقبولة .. ولكنها لم تكتمل .. اكسس عندي 32 بت لذا فتحت النسخة 32 عند الفتح ظهرت هذه الرسالة وعند الموافقة ظهرت واجهة البرنامج ولكن لم تتفاعل ولم اتمكن من اغلاقها الا من خلال مدير المهام

طيب ممكن رايك استاذى الجليل ومعلمى القدير استاذ @jjafferr فى التعديلات التالية والتى تمت على الوحدة انمطية العامة لتحاشى المشكلات السابقة وكذلك قمت بدعم : DCount بناء على توجيهاتكم كود الوحدة النمطية الجديد Option Compare Database Option Explicit Private m_dictHasDataCache As Object Private mbolDebugMode As Boolean ' === تمكين أو تعطيل وضع التتبع (نافذة Immediate) Public Sub EnableDebugMode(Optional ByVal bolEnable As Boolean = True) mbolDebugMode = bolEnable End Sub ' === التحقق من وجود تقرير Private Function ReportExists(ByVal strReportName As String) As Boolean On Error Resume Next ReportExists = Not CurrentProject.AllReports(strReportName) Is Nothing On Error GoTo 0 End Function ' === الحصول على RecordSource Private Function GetRecordSource(ByVal strReportName As String) As String On Error GoTo ErrHandler DoCmd.OpenReport strReportName, acViewPreview, , , acHidden GetRecordSource = Trim(Reports(strReportName).RecordSource) DoCmd.Close acReport, strReportName Exit Function ErrHandler: GetRecordSource = "" End Function ' === تنظيف الكاشات Public Sub ClearCaches() If Not m_dictHasDataCache Is Nothing Then m_dictHasDataCache.RemoveAll End If End Sub ' === تحديد نوع بيانات حقل في جدول أو استعلام Private Function GetFieldDataType(ByVal strRecordSource As String, ByVal strFieldName As String) As Integer Dim dbs As DAO.Database Dim tdf As DAO.TableDef Dim qdf As DAO.QueryDef Dim fld As DAO.Field On Error GoTo ErrHandler Set dbs = CurrentDb On Error Resume Next Set tdf = dbs.TableDefs(strRecordSource) If Err.Number = 0 Then Set fld = tdf.Fields(strFieldName) GetFieldDataType = fld.Type Else Err.Clear Set qdf = dbs.QueryDefs(strRecordSource) If Err.Number = 0 Then Set fld = qdf.Fields(strFieldName) GetFieldDataType = fld.Type Else GetFieldDataType = dbText End If End If On Error GoTo ErrHandler Exit Function ErrHandler: GetFieldDataType = dbText End Function ' === تنسيق المعلمات تلقائيًا بناءً على النوع Public Function FormatParameterValue(varValue As Variant, Optional ByVal dataType As Integer = 0) As String If IsNull(varValue) Or IsEmpty(varValue) Then FormatParameterValue = "NULL" Exit Function End If If dataType = 0 Then Select Case VarType(varValue) Case vbString FormatParameterValue = "'" & Replace(varValue, "'", "''") & "'" Case vbDate FormatParameterValue = "#" & Format(varValue, "mm\/dd\/yyyy") & "#" Case vbBoolean FormatParameterValue = IIf(varValue, "True", "False") Case vbNull, vbEmpty FormatParameterValue = "NULL" Case Else FormatParameterValue = CStr(varValue) End Select Else Select Case dataType Case dbText, dbMemo FormatParameterValue = "'" & Replace(varValue, "'", "''") & "'" Case dbLong, dbInteger, dbByte, dbDouble, dbSingle FormatParameterValue = CStr(varValue) Case dbDate FormatParameterValue = "#" & Format(varValue, "mm\/dd\/yyyy") & "#" Case dbBoolean FormatParameterValue = IIf(varValue, "True", "False") Case Else FormatParameterValue = "NULL" End Select End If End Function ' === تعقيم النصوص لتضمينها داخل استعلامات SQL Public Function SafeSql(strValue As String) As String If IsNull(strValue) Or Trim(strValue) = "" Then SafeSql = "NULL" Else SafeSql = "'" & Replace(strValue, "'", "''") & "'" End If End Function ' === توليد شرط تصفية ذكي بناءً على اسم الحقل والقيمة Public Function BuildFilter( _ ByVal strFieldName As String, _ ByVal varFieldValue As Variant, _ Optional ByVal strRecordSource As String = "") As String If IsNull(varFieldValue) Or IsEmpty(varFieldValue) Or Trim(CStr(varFieldValue)) = "" Then BuildFilter = vbNullString Exit Function End If Dim dataType As Integer If strRecordSource <> "" Then dataType = GetFieldDataType(strRecordSource, strFieldName) Else dataType = 0 ' Use VarType End If BuildFilter = strFieldName & " = " & FormatParameterValue(varFieldValue, dataType) End Function ' === استخراج قيمة من strFilter Private Function ExtractFilterValue(ByVal strFilter As String) As String If InStr(strFilter, "=") > 0 Then Dim strValue As String strValue = Trim(Mid(strFilter, InStr(strFilter, "=") + 1)) strValue = Replace(strValue, "'", "") strValue = Replace(strValue, "#", "") ExtractFilterValue = strValue Else ExtractFilterValue = "" End If End Function ' === التحقق مما إذا كان التقرير يحتوي على بيانات Private Function ReportHasData( _ ByVal strReportName As String, _ Optional ByVal strFilter As String = "", _ Optional ByVal strOpenArgs As String = "", _ Optional ByVal dictParameters As Object = Nothing, _ Optional ByVal bolUseCache As Boolean = True) As Boolean On Error GoTo ExitWithError Dim strDebugMsg As String Dim rpt As Report Dim dbs As DAO.Database Dim qdf As DAO.QueryDef Dim rst As DAO.Recordset Dim prm As DAO.Parameter Dim strRecordSource As String Dim strCacheKey As String Dim strFilterValue As String strDebugMsg = "Report: " & strReportName & vbCrLf & "Filter: " & strFilter & vbCrLf ' --- إنشاء قاموس التخزين المؤقت If m_dictHasDataCache Is Nothing Then Set m_dictHasDataCache = CreateObject("Scripting.Dictionary") End If strCacheKey = strReportName & "|" & strFilter If bolUseCache And m_dictHasDataCache.Exists(strCacheKey) Then ReportHasData = m_dictHasDataCache(strCacheKey) strDebugMsg = strDebugMsg & "Retrieved from Cache: " & ReportHasData & vbCrLf If mbolDebugMode Then Debug.Print strDebugMsg Exit Function End If ' --- الحصول على RecordSource strRecordSource = GetRecordSource(strReportName) If strRecordSource = "" Then strDebugMsg = strDebugMsg & "No RecordSource found" & vbCrLf GoTo OpenAndCheckWithHasData End If strDebugMsg = strDebugMsg & "RecordSource: " & strRecordSource & vbCrLf ' --- محاولة استخدام DCount On Error Resume Next If strFilter <> "" Then If DCount("*", strRecordSource, strFilter) > 0 Then ReportHasData = True m_dictHasDataCache(strCacheKey) = ReportHasData strDebugMsg = strDebugMsg & "DCount HasData: " & ReportHasData & vbCrLf If mbolDebugMode Then Debug.Print strDebugMsg Exit Function End If Else If DCount("*", strRecordSource) > 0 Then ReportHasData = True m_dictHasDataCache(strCacheKey) = ReportHasData strDebugMsg = strDebugMsg & "DCount HasData: " & ReportHasData & vbCrLf If mbolDebugMode Then Debug.Print strDebugMsg Exit Function End If End If Err.Clear On Error GoTo ExitWithError ' --- استخراج قيمة من strFilter إذا كانت موجودة strFilterValue = ExtractFilterValue(strFilter) strDebugMsg = strDebugMsg & "Extracted Filter Value: " & strFilterValue & vbCrLf ' --- محاولة التحقق باستخدام RecordSource Set dbs = CurrentDb On Error Resume Next Set qdf = dbs.QueryDefs(strRecordSource) If Err.Number = 0 And qdf.Parameters.Count > 0 Then strDebugMsg = strDebugMsg & "Parameters Count: " & qdf.Parameters.Count & vbCrLf For Each prm In qdf.Parameters strDebugMsg = strDebugMsg & "Parameter: " & prm.Name & vbCrLf If Not dictParameters Is Nothing And dictParameters.Exists(prm.Name) Then prm.Value = FormatParameterValue(dictParameters(prm.Name), prm.Type) strDebugMsg = strDebugMsg & "Assigned from dictParameters: " & prm.Value & vbCrLf ElseIf InStr(prm.Name, "Forms!") > 0 Then Dim strFormName As String strFormName = Split(prm.Name, "!")(1) If CurrentProject.AllForms(strFormName).IsLoaded Then prm.Value = Eval(prm.Name) strDebugMsg = strDebugMsg & "Assigned from Eval(" & prm.Name & "): " & prm.Value & vbCrLf Else strDebugMsg = strDebugMsg & "Form not loaded: " & strFormName & vbCrLf GoTo OpenAndCheckWithHasData End If ElseIf strFilterValue <> "" Then prm.Value = FormatParameterValue(strFilterValue, prm.Type) strDebugMsg = strDebugMsg & "Assigned from strFilterValue: " & prm.Value & vbCrLf Else strDebugMsg = strDebugMsg & "No value for parameter: " & prm.Name & vbCrLf GoTo OpenAndCheckWithHasData End If Next prm Set rst = qdf.OpenRecordset(dbOpenSnapshot, dbReadOnly) If Err.Number = 0 Then ReportHasData = Not rst.EOF strDebugMsg = strDebugMsg & "Recordset HasData: " & ReportHasData & vbCrLf rst.Close m_dictHasDataCache(strCacheKey) = ReportHasData If mbolDebugMode Then Debug.Print strDebugMsg Exit Function End If Err.Clear End If On Error GoTo ExitWithError OpenAndCheckWithHasData: ' --- فتح التقرير مؤقتًا في الخلفية (كملاذ أخير) DoCmd.OpenReport strReportName, acViewPreview, , strFilter, acHidden, strOpenArgs Set rpt = Reports(strReportName) ReportHasData = (rpt.HasData <> 0) strDebugMsg = strDebugMsg & "Report HasData: " & ReportHasData & vbCrLf DoCmd.Close acReport, strReportName m_dictHasDataCache(strCacheKey) = ReportHasData If mbolDebugMode Then Debug.Print strDebugMsg Exit Function ExitWithError: strDebugMsg = strDebugMsg & "Error: " & Err.Number & " - " & Err.Description & vbCrLf ReportHasData = True ' افتراض وجود بيانات إذا فشل التحقق If mbolDebugMode Then Debug.Print strDebugMsg End Function ' === دالة رئيسية لفتح التقارير الذكية Public Function OpenReportSmart( _ ByVal strReportName As String, _ Optional ByVal bolConfirm As Boolean = True, _ Optional ByVal enmView As AcView = acViewNormal, _ Optional ByVal strWhereCondition As String = vbNullString, _ Optional ByVal varOpenArgs As Variant, _ Optional ByVal bolSilentMode As Boolean = False, _ Optional ByVal dictParameters As Object = Nothing, _ Optional ByVal bolUseCache As Boolean = True, _ Optional ByVal bolSkipDataCheck As Boolean = False) As Boolean Const strTitleConfirm As String = "تأكيد" Const strTitleAlert As String = "تنبيه" Const strTitleError As String = "خطأ" Dim strFilter As String Dim strArgs As String Dim strRecordSource As String On Error GoTo ExitWithError ' --- التحقق من وجود التقرير If Not ReportExists(strReportName) Then If Not bolSilentMode Then MsgBox "التقرير '" & strReportName & "' غير موجود.", vbExclamation + vbMsgBoxRight + vbMsgBoxRtlReading, strTitleAlert End If OpenReportSmart = False Exit Function End If ' --- التحقق من RecordSource strRecordSource = GetRecordSource(strReportName) If strRecordSource = "" Then If Not bolSilentMode Then MsgBox "التقرير '" & strReportName & "' لا يحتوي على مصدر بيانات.", vbExclamation + vbMsgBoxRight + vbMsgBoxRtlReading, strTitleAlert End If OpenReportSmart = False Exit Function End If ' --- تنسيق الفلتر والمعلمات strFilter = Nz(strWhereCondition, vbNullString) If Not IsMissing(varOpenArgs) Then strArgs = CStr(varOpenArgs) ' --- التأكيد قبل الفتح If bolConfirm And Not bolSilentMode Then If MsgBox("هل تريد عرض التقرير: " & vbCrLf & strReportName & "؟", vbQuestion + vbYesNo + vbMsgBoxRight + vbMsgBoxRtlReading, strTitleConfirm) = vbNo Then OpenReportSmart = False Exit Function End If End If ' --- التحقق من وجود بيانات (إذا لم يُطلب تخطي التحقق) If Not bolSkipDataCheck Then If Not ReportHasData(strReportName, strFilter, strArgs, dictParameters, bolUseCache) Then If Not bolSilentMode Then MsgBox "التقرير لا يحتوي على بيانات.", vbInformation + vbMsgBoxRight + vbMsgBoxRtlReading, strTitleAlert End If OpenReportSmart = False Exit Function End If End If ' --- فتح التقرير DoCmd.OpenReport strReportName, enmView, , strFilter, , strArgs If mbolDebugMode Then Debug.Print "تم فتح التقرير: " & strReportName If strFilter <> "" Then Debug.Print ">> الفلتر: " & strFilter If strArgs <> "" Then Debug.Print ">> OpenArgs: " & strArgs End If OpenReportSmart = True Exit Function ExitWithError: Select Case Err.Number Case 2501, 2212 If Not bolSilentMode Then MsgBox "تم إلغاء عملية الطباعة أو تعذر العثور على التقرير.", vbExclamation + vbMsgBoxRight + vbMsgBoxRtlReading, strTitleAlert End If Case Else If Not bolSilentMode Then MsgBox "حدث خطأ أثناء فتح التقرير: " & Err.Number & " | " & Err.Description, vbExclamation + vbMsgBoxRight + vbMsgBoxRtlReading, strTitleError End If End Select OpenReportSmart = False End Function ودى دالة توثيقية لامثلة الاستدعاء المختلفة ' === دالة توثيقية: أمثلة استخدام OpenReportSmart Private Sub OpenReportSmart_Examples() #If False Then Dim strFilter As String Dim strRecordSource As String ' [01] استدعاء بسيط لفتح تقرير بدون فلتر أو تأكيد Call OpenReportSmart("rptEmployees", False) ' [02] فتح تقرير في وضع المعاينة مع تأكيد Call OpenReportSmart("rptEmployees", True, acViewPreview) ' [03] تصفية بسيطة باستخدام شرط ثابت Call OpenReportSmart("rptEmployees", True, acViewPreview, "DepartmentID = 5") ' [04] فتح تقرير مع OpenArgs لتمرير معلومات إضافية Call OpenReportSmart("rptEmployees", True, acViewPreview, , "ShowSummary") ' [05] فتح تقرير في الوضع الصامت (بدون رسائل خطأ) Call OpenReportSmart("rptEmployees", , , , , True) ' [06] استدعاء كامل مع فلتر، OpenArgs، وتأكيد Call OpenReportSmart("rptEmployees", True, acViewPreview, "IsActive = True", "FromMainMenu", False) ' [07] تصفية ديناميكية من نموذج باستخدام BuildFilter If CurrentProject.AllForms("frmEmployeeSelector").IsLoaded Then strRecordSource = GetRecordSource("rptEmployeeAttendance") strFilter = BuildFilter("EmployeeID", Forms!frmEmployeeSelector!cboEmployeeID, strRecordSource) Call OpenReportSmart("rptEmployeeAttendance", True, acViewNormal, strFilter) End If ' [08] تصفية بتاريخ باستخدام BuildFilter strRecordSource = GetRecordSource("rptDailySummary") strFilter = BuildFilter("ReportDate", Date, strRecordSource) Call OpenReportSmart("rptDailySummary", True, acViewPreview, strFilter) ' [09] تصفية بنص باستخدام BuildFilter Dim strEmployeeName As String strEmployeeName = "محمد علي" strRecordSource = GetRecordSource("rptEmployees") strFilter = BuildFilter("EmployeeName", strEmployeeName, strRecordSource) Call OpenReportSmart("rptEmployees", True, acViewPreview, strFilter) ' [10] فتح تقرير مع تخطي التحقق من البيانات (لتقليل التأخير) Call OpenReportSmart("rptEmployees", True, acViewPreview, , , , , , True) ' [11] مثال مشابه لـ rpt01StudentsLists مع فلتر Period If CurrentProject.AllForms("frmStudentsFilter").IsLoaded Then strRecordSource = GetRecordSource("rpt01StudentsLists") strFilter = BuildFilter("Period", Forms!frmStudentsFilter!cboPeriod, strRecordSource) Call OpenReportSmart("rpt01StudentsLists", True, acViewPreview, strFilter, Forms!frmStudentsFilter!cboPeriod) End If ' [12] فتح تقرير مع فلتر معقد وتخطي التحقق من البيانات strFilter = "DepartmentID = 5 AND IsActive = True" Call OpenReportSmart("rptEmployees", True, acViewPreview, strFilter, , , , , True) ' [13] فتح تقرير مع تعطيل التخزين المؤقت strRecordSource = GetRecordSource("rptEmployees") strFilter = BuildFilter("DepartmentID", 10, strRecordSource) Call OpenReportSmart("rptEmployees", True, acViewPreview, strFilter, , , , False) #End If End Sub

تحديث واستكمال للتوضيح عند عمل نموذج مستمر اعتيادي مع تقيد الحقول بتنشيق الشرطي سيكون وميض وترميش نصف النموضج لكل حركة ( عند الغاء التنسيق الشرطي لا وميض ولا ترميش بملايين السجلات ) واذا استخدمة حقل او حقلين لتنسيق شرطي سوف يكون خفيف في الاسفل والاعلى النموذج وميض وترميش فقدمة لك الحل البديل بلا ترميش وميض والكل تنسيق شرطي مع سرعة التنقل 1- اضافة عرض مباشر 10000 الف سجل سرعة مناسبة مقسم ويعمل مع استعلام العادي ويمكنك التحكم بتعديل عدد السجلات داخل الكود 2- استعلام عادي لعرض التواريخ المنتهية ولم تنتهي في الموجموعات 3- بحث لكافة الجداول المرتبطة عن رقم فريد كرقم المدني القومي وملاحظة عند البحث ستجد عند جدول واحد لان البحث برقم ID متشابهة لجداول المرتبطه 4- استخدام التنسيق الرشرطي Caption 5- اضافة فحص للجداول بتحديد من حقل قائمة جم يشيل 😇 6- مع بعض التصحيحات وتحسينات تحميل المرفق https://www.mediafire.com/file/uoe599ymzy53g0p/Update_2Miluon_Record_IN_One_Speed_Read_db_Caption_Filter.rar/file يجب اختيار زر انشاء عشر جداول ثم زر الاتصال ثم زر اضافة بيانات وهمية ثم التشغيل😇 للتجرب الى تحديث التالي مع المعالجة

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

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

أخي الفاضل ، وعليكم السلام ورحمة الله وبركاته .. لو انك امعنت النظر في الأكواد لكان الأمر قد تبين لك أين عليك التعديل !!! هل هذه الصورة صحيحة ؟ إن كانت صحيحة ، فقط نفس الكود السابق ولكن نقلب الإشارات الأكبر تصبح أصغر والعكس Private Sub تفصيل_Paint() If Me.B3.Value < 9 Then Me.أمر56.Transparent = True Else Me.أمر56.Transparent = False End If End Sub Private Sub Form_Current() Dim bVisible As Boolean bVisible = (Me.B3.Value > 9 Or IsNull(Me.B3)) With Me.أمر56 .Transparent = Not bVisible .Enabled = bVisible End With End Sub

اخي افاضل السلام عليكم شكرا على المجهوداتكم اخفاء ايقونة طلب الاستخلاف عندما يكون عدد الغياب اقل من 09 ايام العطلة التي مدتها يوم واحد الى 9 ايام لا نطلب استخلاف

وعليكم السلام ورحمة الله وبركاته .. هذه فكرة بسيطة تم تنفيذها سابقاً في أحد المشاريع لأحد الأخوة . تتلخص في الحدثين التاليين :- Private Sub تفصيل_Paint() If Me.B3.Value > 9 Then Me.أمر56.Transparent = True Else Me.أمر56.Transparent = False End If End Sub Private Sub Form_Current() Dim bVisible As Boolean bVisible = (Me.B3.Value < 9 Or IsNull(Me.B3)) With Me.أمر56 .Transparent = Not bVisible .Enabled = bVisible End With End Sub الملف بعد التعديل :- 1234 (6).zip

السلام عليكم لدي نموذج فرعي لقد قمت بادخال كود لاخفاء ايقونة طلب الاستخلاف عندما يكون عدد الغياب اقل من 09 ايام وعندما الضغط على الايقونة للموظف اخر تظهر جميع الازرار اريد اخفاء ايقونة طلب الاستخلاف عندما يكون عدد الغياب اقل من 09 ايام فقط اما اكثر من عشرة ايام تظهر الايقونة طلب استخلاف.rar

حسناً أخي الكريم ، ما رأيك بتصحيح جزء من المشكلة بحيث تبدأ بفهم كيفية كتابة الأكواد بشكل مفهوم ؟؟ في الكود التالي زر الإضافة في المرحلة الأولى ، وقد أضفت شرحاً بسيطاً أتمنى ان يكون مفهوماً لك . مع العلم ان معظم مشاكلك كانت في تسمية الأوراق ( الورقة1 و الورقة2 ) حيث انهما غير موجودات أساساَ . بل اسمهما الصحيح في ملفك = Sheet1 و Sheet2 ... انظر للكود وحاول مجاراته وفهمه . واستبدله في زر الإضافة وقم بالتنفيذ على باقي الأكواد بأسلوبك الذي فهمته . وإذا استعصى عليك شيء لا تتردد أو تبخل على نفسك بطرح السؤال . Private Sub Cmdadd_Click() Dim wsSource As Worksheet Dim wsTarget As Worksheet Dim lastRow As Long ' هنا سنقوم بتحديد أسماء الأوراق المصدر والهدف Set wsSource = Worksheets("Sheet1") Set wsTarget = Worksheets("Sheet2") ' A هنا سنحاول البحث عن أول صف فارغ وتحديداً من العمود lastRow = 4 ' نبدأ من الصف 4 حسب تصميم الورقة الثانية لديك ' إذا كان الصف 4 غير فارغ ، نبحث عن أول صف فارغ أسفله If wsTarget.Cells(4, "A").Value <> "" Then lastRow = wsTarget.Cells(4, "A").End(xlDown).Row + 1 ' إذا وصلنا إلى نهاية البيانات (أي لا توجد خلايا فارغة) ، نستخدم آخر صف ونضيف له 1 If lastRow > wsTarget.Rows.Count Then lastRow = wsTarget.Cells(wsTarget.Rows.Count, "A").End(xlUp).Row + 1 End If End If ' نتأكد من ان النطاق المحدد صحيح ويقع بين 4 وأكبر قيمة يسمح بها اكسل If lastRow < 4 Then lastRow = 4 If lastRow > wsTarget.Rows.Count Then lastRow = wsTarget.Rows.Count 'بدء نقل البيانات من الورقة الأولى إلى الورقة الثانية With wsSource wsTarget.Cells(lastRow, "A").Value = .Range("E5").Value wsTarget.Cells(lastRow, "B").Value = .Range("E7").Value wsTarget.Cells(lastRow, "C").Value = .Range("E9").Value wsTarget.Cells(lastRow, "D").Value = .Range("E11").Value wsTarget.Cells(lastRow, "E").Value = .Range("J5").Value wsTarget.Cells(lastRow, "F").Value = .Range("J7").Value wsTarget.Cells(lastRow, "G").Value = .Range("J9").Value wsTarget.Cells(lastRow, "H").Value = .Range("J11").Value wsTarget.Cells(lastRow, "I").Value = .Range("D13").Value wsTarget.Cells(lastRow, "J").Value = .Range("E13").Value wsTarget.Cells(lastRow, "K").Value = .Range("F13").Value wsTarget.Cells(lastRow, "P").Value = .Range("I13").Value wsTarget.Cells(lastRow, "Q").Value = .Range("J13").Value wsTarget.Cells(lastRow, "R").Value = .Range("K13").Value wsTarget.Cells(lastRow, "W").Value = .Range("D15").Value wsTarget.Cells(lastRow, "X").Value = .Range("E15").Value wsTarget.Cells(lastRow, "Y").Value = .Range("F15").Value wsTarget.Cells(lastRow, "AD").Value = .Range("I15").Value wsTarget.Cells(lastRow, "AE").Value = .Range("J15").Value wsTarget.Cells(lastRow, "AF").Value = .Range("K15").Value wsTarget.Cells(lastRow, "AK").Value = .Range("D17").Value wsTarget.Cells(lastRow, "AL").Value = .Range("E17").Value wsTarget.Cells(lastRow, "AM").Value = .Range("F17").Value wsTarget.Cells(lastRow, "AR").Value = .Range("I17").Value wsTarget.Cells(lastRow, "AS").Value = .Range("J17").Value wsTarget.Cells(lastRow, "AT").Value = .Range("K17").Value wsTarget.Cells(lastRow, "AY").Value = .Range("D19").Value wsTarget.Cells(lastRow, "AZ").Value = .Range("E19").Value wsTarget.Cells(lastRow, "BA").Value = .Range("F19").Value wsTarget.Cells(lastRow, "BF").Value = .Range("I19").Value wsTarget.Cells(lastRow, "BG").Value = .Range("J19").Value wsTarget.Cells(lastRow, "BH").Value = .Range("K19").Value wsTarget.Cells(lastRow, "BM").Value = .Range("D21").Value wsTarget.Cells(lastRow, "BN").Value = .Range("E21").Value wsTarget.Cells(lastRow, "BO").Value = .Range("F21").Value wsTarget.Cells(lastRow, "BT").Value = .Range("I21").Value wsTarget.Cells(lastRow, "BU").Value = .Range("J21").Value wsTarget.Cells(lastRow, "BV").Value = .Range("K21").Value End With ' مسح البيانات من الورقة الأولى On Error Resume Next ' تجاوز الأخطاء مؤقتًا Set rngToClear = wsSource.Range("E5,E7,E9,E11,J5,J7,J9,J11,D13:F13,I13:K13,D15:F15,I15:K15,D17:F17,I17:K17,D19:F19,I19:K19,D21:F21,I21:K21") For Each cell In rngToClear If Not cell.MergeCells Then ' إذا لم تكن الخلية جزءً من دمج cell.ClearContents Else ' إذا كانت الخلية جزءً من دمج cell.MergeArea.ClearContents ' مسح محتوى نطاق الدمج بالكامل End If Next cell On Error GoTo 0 ' إعادة تفعيل مكتشف الأخطاء MsgBox "تم ترحيل البيانات بنجاح", vbInformation + vbMsgBoxRight, "تم" End Sub

جزاكم الله كل خير شرح ممتاز و فهمت المقصود منه - ربنا يبارك لك في علمك و يزيدك من العلم النافع و يوسع لك في رزقك

السلام عليكم ورحمة الله أشارك معكم اليوم أكواد داخل وحدة نمطية عامة تم تطويرها لتصفية محتويات أي مربع سرد (ComboBox) في أي نموذج بشكل ديناميكي بمجرد الكتابة داخل مربع التحرير والسرد تصفية ديناميكية: يدعم التصفية المتعددة باستخدام أكثر من حقل (مثل الاسم + الرقم القومي) تدعم التصفية على حقل واحد أو حقول متعددة باستخدام نمط LIKE '*...*' وذلك لتتم التصفية بناء على اى جزء من الكلمة الكود داخل الوحده النمطية العامة Option Compare Database Option Explicit Private dictRowSources As Object Private strLastFilterValue As String Private strLastComboName As String Private Sub EnsureDictionary() If dictRowSources Is Nothing Then Set dictRowSources = CreateObject("Scripting.Dictionary") End If End Sub Public Sub ClearComboMemory(ByVal frm As Access.Form) Dim strKey As Variant Call EnsureDictionary For Each strKey In dictRowSources.Keys If Left(strKey, Len(frm.Name) + 1) = frm.Name & "." Then dictRowSources.Remove strKey End If Next End Sub Public Sub FilterCombo(ByVal frm As Access.Form, _ ByVal strComboName As String, _ Optional ByVal strFilterField As String = "") Dim cmb As Access.ComboBox Dim strSourceSQL As String Dim strFilterValue As String Dim strFilteredSQL As String Dim strOrderByClause As String Dim strKey As String Dim objRegex As Object Dim objMatches As Object Dim arrFilterFields As Variant Dim strWhereClause As String Dim i As Long On Error GoTo ExitWithError ' التحقق من صحة النموذج وعنصر التحكم If frm Is Nothing Then MsgBox "النموذج غير صالح.", vbExclamation Exit Sub End If ' Debug.Print "Form: " & frm.Name ' Debug.Print "ComboBox: " & strComboName Set cmb = frm.Controls(strComboName) ' التحقق من مصدر البيانات Call EnsureDictionary strKey = frm.Name & "." & cmb.Name If dictRowSources.Exists(strKey) Then strSourceSQL = dictRowSources(strKey) Else strSourceSQL = Trim(Replace(cmb.RowSource & "", ";", "")) ' إزالة الفاصلة المنقوطة ' Debug.Print "RowSource: " & strSourceSQL If Len(strSourceSQL) = 0 Then MsgBox "مصدر البيانات غير صالح.", vbExclamation Exit Sub End If dictRowSources.Add strKey, strSourceSQL End If ' إعادة تعيين المصدر إذا لم يتم توفير حقل تصفية If Len(strFilterField) = 0 Then If cmb.RowSource <> strSourceSQL Then cmb.RowSource = strSourceSQL End If cmb.Requery cmb.Dropdown strLastFilterValue = "" strLastComboName = strComboName Exit Sub End If ' التحقق من نوع عنصر التحكم النشط If TypeOf Screen.ActiveControl Is Access.TextBox Or TypeOf Screen.ActiveControl Is Access.ComboBox Then strFilterValue = Nz(Screen.ActiveControl.Text, vbNullString) ' Debug.Print "ActiveControl: " & Screen.ActiveControl.Name ' Debug.Print "FilterValue: " & strFilterValue Else ' Debug.Print "ActiveControl is not TextBox or ComboBox" If cmb.RowSource <> strSourceSQL Then cmb.RowSource = strSourceSQL End If cmb.Requery cmb.Dropdown strLastFilterValue = "" strLastComboName = strComboName Exit Sub End If ' إعادة تعيين المصدر إذا كانت القيمة المصفاة فارغة If Len(strFilterValue) = 0 Then If cmb.RowSource <> strSourceSQL Then cmb.RowSource = strSourceSQL End If cmb.Requery cmb.Dropdown strLastFilterValue = "" strLastComboName = strComboName Exit Sub End If ' التحقق مما إذا كانت القيمة المصفاة أو ComboBox قد تغيرت If strFilterValue = strLastFilterValue And strComboName = strLastComboName Then cmb.Requery cmb.Dropdown Exit Sub End If ' استخدام Regex لاستخراج ORDER BY Set objRegex = CreateObject("VBScript.RegExp") With objRegex .Global = True .IgnoreCase = True .Pattern = "\s*ORDER\s+BY\s+.*$" End With Set objMatches = objRegex.Execute(strSourceSQL) If objMatches.Count > 0 Then strOrderByClause = objMatches(0).Value strSourceSQL = Trim(Replace(strSourceSQL, strOrderByClause, "")) Else strOrderByClause = "" End If ' Debug.Print "SourceSQL: " & strSourceSQL ' Debug.Print "OrderBy: " & strOrderByClause ' التحقق من الحقول وإنشاء شرط WHERE لحقول متعددة If Len(strFilterField) > 0 Then arrFilterFields = Split(strFilterField, ",") strWhereClause = "" For i = LBound(arrFilterFields) To UBound(arrFilterFields) Dim strField As String strField = Trim(arrFilterFields(i)) If Len(strField) > 0 Then If Len(strWhereClause) > 0 Then strWhereClause = strWhereClause & " OR " strWhereClause = strWhereClause & strField & " LIKE '*" & Replace(strFilterValue, "'", "''") & "*'" End If Next i If Len(strWhereClause) = 0 Then MsgBox "تعبير التصفية غير صالح: " & strFilterField, vbExclamation Exit Sub End If On Error Resume Next strFilteredSQL = strSourceSQL & " WHERE (" & strWhereClause & ")" & strOrderByClause ' Debug.Print "FilteredSQL: " & strFilteredSQL cmb.RowSource = strFilteredSQL If Err.Number <> 0 Then MsgBox "تعبير التصفية غير صالح: " & strFilterField & vbCrLf & "Error: " & Err.Description, vbExclamation On Error GoTo ExitWithError Exit Sub End If On Error GoTo ExitWithError Else strFilteredSQL = strSourceSQL & strOrderByClause cmb.RowSource = strFilteredSQL End If ' تعيين المصدر المصفى وتحديث واجهة المستخدم cmb.Requery cmb.Dropdown strLastFilterValue = strFilterValue strLastComboName = strComboName Exit Sub ExitWithError: Select Case Err.Number Case 2118 Resume Next Case Else MsgBox "حدث خطأ أثناء التصفية: " & Err.Number & " | " & Err.Description, vbExclamation End Select End Sub الاستدعاء فى النموذج في حدث Click : لإعادة تحميل القائمة الأصلية لمربع السرد عند الضغط عليه ' في حدث Click Private Sub ComboBoxName_Click() FilterCombo Me, "ComboBoxName" End Sub وايضا في حدث KeyUp : لتصفية القيم أثناء الكتابة في مربع السرد حسب حقل واحد ' في حدث KeyUp Private Sub ComboBoxName_KeyUp(KeyCode As Integer, Shift As Integer) FilterCombo Me, "ComboBoxName", "FieldName" End Sub مع امكانية في حدث KeyUp : لتصفية القيم أثناء الكتابة في مربع السرد حسب أكثر من حقل ' في حدث KeyUp لعمل التصفية المتعددة Private Sub ComboBoxName_KeyUp(KeyCode As Integer, Shift As Integer) FilterCombo Me, "ComboBoxName", "FieldName, FieldName2" End Sub تحياتى Filter inside the Combobox.accdb

الله يبارك فيك و يعطيك من فضله الكثير