ابو جودي

ايون ينفع نعم <> False يعمل لكنه أقل وضوح من <> 0 أو > 0 تذكر أن InStr ترجع رقم موضع وليس قيمة منطقية لذلك من الطبيعي تقارنها بأرقام مش بقيم منطقية

الدالة InStr تبحث عن وجود سلسلة نصية داخل سلسلة أخرى ترجع الموضع الرقمي لأول ظهور للجزء المطلوب (أي رقم أكبر من صفر) إذا تم العثور عليه وترجع الرقم 0 إذا لم يتم العثور على الجزء المطلوب تركيب الدالة هو: InStr([النص الأصلي], [النص الذى نريد البحث عنه]) اذا InStr([Modah];"-")<>0 [Modah] هو الحقل الذي يحتوي على البيانات النصية اى هو النص الأصلى "-" هو النص الذى نريد البحث عنه >-->> علامة السالب <>0 تعني طالما أن علامة السالب موجودة في أي موضع داخل النص فيعتبر الشرط صحيح طيب بالنسبة لسؤال حضرتك الفاصلة في الحقل ":" لكن الفاصلة في الدالة "-" نركز فقط على ظهور علامة السالب (-) داخل القيمة الكاملة للحقل وليس على علاقة للفاصل ":" هنا لأننا لا نقوم بتقسيم القيمة بل فقط نبحث عن وجود علامة السالب (-) لماذا لم تلون القيم التي تحتوي على صفر؟ لأن الشرط يبحث فقط عن وجود السالب علامة السالب (-) "0:0" لا تحتوي على علامة السالب (-) الشرط يعطي False فلا يتم تلوينه "-0:1" تحتوي على علامة السالب (-) الشرط يعطي True فلذلك يتم تلوينه

فقط استخدم فى خاصية التسيق الشرطى لعنصر هذا الحقل InStr([FieldName],"-")<>0 طبعا مع تغيير : FieldName بما يتناسب معك واختر اللون هذا اقصر طريق داخل التقرير ولو تريد التصفية فقط فى الاستعلام للقيم الموجبة استخدم فى معيار الحقل: FieldName >InStr([FieldName],"-")<>0 اما لو تريد القيم السالبة فقط فى معيار الحقل : FieldName InStr([FieldName],"-")<>0

ههههههههههههه أنت أرتحت وأنا خلاص على ايدك خلصت التكـه و وصلت لآخر السكـة قابلوا بئه اللى راح حمادة واللى جاى حماااادة تااااااانى خالص ... انتوا اللى جيبتوه لنفسكم

انت تقصد لاقيت نفسك فاضى قلت فى عقل بالك تعمل ايه تعمل ايه يا واد فؤش اه الواد او جودى هنا وعمال يخبط دماغه فى الحيط .. اسيبــه ؟! .... لا ... اروح اعمل له Error فى دماغه بزياده قبل ما يروح على شغله وبعدين ادخل انام عاش عليك يا فؤش خلاااااااااااااااااااص مباقاش فاضل تكـــــــــه بح خلاص على ايدك يا فؤش أفندى خلصت التكـه

يا فؤش افندى لا يعيب الكود كثرة الاسطر أو طوله انت استخدمت : سلسلة مباشرة انا استخدمت : مصفوفة ثم Join واستخدمت شرط للتحقق من البداية والنهاية واعتقد ان (مصفوفة ثم Join) : أسرع وأكثر كفاءة عند كثرة التواريخ (المصفوفة أفضل من تجميع نصي مباشر) غير كده مفيش أى فروقات تانى عير الفاصلة فــ إيه بئه أنا مش فاهم

من أجل ذلك كتبت الكود بالشكل ده يا استاذ فؤش Public Function GetDatesBetween(ByVal dtmStartDate As Date, ByVal dtmEndDate As Date) As String If dtmStartDate > dtmEndDate Then GetDatesBetween = "" Exit Function End If Dim dtmCurrentDate As Date Dim arrDates() As String ReDim arrDates(0 To DateDiff("d", dtmStartDate, dtmEndDate)) Dim lngIndex As Long For dtmCurrentDate = dtmStartDate To dtmEndDate arrDates(lngIndex) = Format(dtmCurrentDate, "yyyy-mm-dd") lngIndex = lngIndex + 1 Next dtmCurrentDate GetDatesBetween = Join(arrDates, " | ") End Function

طيب استاذى الجليل ومعلمى القدير و والدى الحبيب الاستاذ @ابوخليل يبدو ان الفكرة هذه تخص تسجيل اجازة او مأمورية او تدريب او شئ من هذا القبيل بين فترين أولا انا حاولت وضع كل الاجابات وكل ما خطر بالى فيما يخص السؤال والموضوع بقدر الامكان حسب فهمى المتواضع ولكن ولكن لكن وبناء على تجارب عملية الافضل هو تسجيل التواريخ جميعا من خلال لوب بداية من اول تاريخ الى اخر تاريخ فى الجدول المخصص من البداية على هيئة سجلات الميزة والافضلية اولا لاى سبب عارض اى تغيير فى المستقبل بين الفترات يسهل حذفه وناهيك عن سهولة تطبيق باقى العمليات والاجراءات التى تخطر على بالك فى الوقت الراهن او لم تخطر حتى الان وقدم تسبب مشاكل فى المستقبل والتى فى النهاية جعلتك تحاول تفكيك التواريخ الى سجلات لنعطى مثال صغير وهذا طبقته بشكل عملى فى مؤسستى لنفترض ان موظف ما قدم طلب اجازة اعتيادية مثلا من يوم 1/7/2025 وحتى 10/7/2025 تتم عملية التسجيل لكل تاريخ سجل منفرد بكود الموظف والتاريخ ونوع اليومية مع استبعاد ايام العطلات من اللوب سواء كانت رسمية او غير رسمية الميزة هنا : عدد السجلات لهذا الموظف وحسب نوع اليومية هو اجمالى ما حصل الموظف عليه او سوف يحصل عليه لهذا النوع ان كانت فى تواريخ مستقبلية طيب لنفترض ان عدد السجلات كان 7 اذا هو يمثل 7 ايام ب 7 تواريخ من تاريخ البدء وحتى تاريخ الانتهاء طيب لفترض ان الموظف اخذ فقط يومين وقطع الاجازة وعاد الى العمل ولم يخبر المختص لاعادة التعديل لأى سبب حتى يتم اعادة ضبط الرصيد وفق الواقع انا صممت استعلام يبدأ مع فتح نموذج التسجيل يطابق هذا الجدول مع جدول الحضور الخاص بالبصمة و وفق التواريخ التى لها بصمة حضور وتساوت مع تواريح فى جدول اليوميات مثلا على انها اجازة يتم حذفها تلقائيا من جدول الاجازات بذلك يتم تصحيح الرصيد بشكل الى وبدون تدخل بشرى اعتقد فرد التواريخ من البداية ليكون كل تاريخ فى سجل له الافضلية ويضفى المرونة القصوى اثناء معالجة البيانات ويلبى العديد من الرغبات بشتى الافكار حسب المتطلبات الحالية أو التى تطرأ فى المستقبل

طيب دى فكرة تانى لو لا تريد عمل جداول مؤقته او حتى جدول ثابت لمعالجة موضوع التواريخ وان كنت لا تريد كذلك الاعتماد على جداول مساعدة كالجدول الاخير : tbl2 الكود Public Sub GenerateSafeUnionQuery() Dim db As DAO.Database Dim rs As DAO.Recordset Dim dtmStart As Date, dtmEnd As Date, dtmCurrent As Date Dim lngUserID As Long Dim strSQL As String Dim strOneLine As String Dim bolFirst As Boolean Set db = CurrentDb Set rs = db.OpenRecordset("SELECT user_id, startA, endA FROM tbl1", dbOpenSnapshot) bolFirst = True Do Until rs.EOF lngUserID = rs!user_id dtmStart = Nz(rs!startA, 0) dtmEnd = Nz(rs!endA, 0) If IsDate(dtmStart) And IsDate(dtmEnd) And dtmStart <= dtmEnd Then For dtmCurrent = dtmStart To dtmEnd ' استخدام جدول فعلي لتجنب التكرارات strOneLine = "SELECT " & lngUserID & " AS user_id, #" & Format(dtmCurrent, "yyyy-mm-dd") & "# AS dateField FROM (SELECT TOP 1 * FROM tbl1)" If bolFirst Then strSQL = strOneLine bolFirst = False Else strSQL = strSQL & vbCrLf & "UNION ALL" & vbCrLf & strOneLine End If Next dtmCurrent End If rs.MoveNext Loop rs.Close Set rs = Nothing ' حذف الاستعلام القديم (لو موجود) On Error Resume Next db.QueryDefs.Delete "qryUnioUserDates" db.QueryDefs.Delete "qryFinalUserDates" On Error GoTo 0 ' إنشاء الاستعلام الأساسي UNION db.CreateQueryDef "qryUnioUserDates", strSQL ' إنشاء استعلام مبني عليه db.CreateQueryDef "qryFinalUserDates", "SELECT * FROM qryUnioUserDates;" ' إظهار الاستعلام مباشرة DoCmd.OpenQuery "qryFinalUserDates", acViewNormal MsgBox "تم إنشاء الاستعلامين بنجاح، والاستعلام النهائي تم فتحه.", vbInformation End Sub طبعا الاستدعاء للدالة : GenerateSafeUnionQuery يقوم بعمل استعلامين بشكل ديناميكى الاساسى : qryUnioUserDates ومبنى عليه الاستعلام الثانى : qryFinalUserDates والذى نتيجته كما هو مطلوب تماما ولكن يعيب هذه الفكرة شئ واحد لابد من استدعاء الداله دائما : GenerateSafeUnionQuery مع اى تحديث يتم على الجدول : tbl1 ---------------------------- أفكار أخرى لا تعتمد على جدول مساعد او جدول مؤقت او حتى جدول ثابت الكود الاساسى فى وحده نمطية عامة Private Const adInteger = 3 Private Const adDBTimeStamp = 135 Private Const adOpenStatic = 3 Private Const adLockOptimistic = 3 Public Function GetSplitDatesRecordset() As Object Dim db As DAO.Database Dim rsSource As DAO.Recordset Dim rsTemp As Object Dim arrDates() As String Dim i As Long Dim lngUserID As Long Dim strDates As String Set rsTemp = CreateObject("ADODB.Recordset") rsTemp.Fields.Append "user_id", adInteger rsTemp.Fields.Append "SingleDate", adDBTimeStamp rsTemp.CursorType = adOpenStatic rsTemp.LockType = adLockOptimistic rsTemp.Open Set db = CurrentDb Set rsSource = db.OpenRecordset("SELECT user_id, GetDatesBetween([startA], [endA]) AS DateList FROM tbl1", dbOpenSnapshot) Do While Not rsSource.EOF lngUserID = rsSource!user_id strDates = Nz(rsSource!DateList, "") If Len(strDates) > 0 Then arrDates = Split(strDates, " | ") For i = LBound(arrDates) To UBound(arrDates) If IsDate(arrDates(i)) Then rsTemp.AddNew rsTemp!user_id = lngUserID rsTemp!SingleDate = CDate(arrDates(i)) rsTemp.Update End If Next i End If rsSource.MoveNext Loop rsSource.Close Set rsSource = Nothing Set db = Nothing If Not rsTemp.EOF Then rsTemp.MoveFirst Set GetSplitDatesRecordset = rsTemp End Function Public Sub LoadDatesIntoForm(frm As Object) Dim rs As Object Set rs = GetSplitDatesRecordset() If rs.EOF Then MsgBox "لا توجد تواريخ!", vbExclamation Exit Sub End If If TypeOf frm Is Form Then Set frm.Recordset = rs ElseIf TypeOf frm Is Access.SubForm Then Set frm.Form.Recordset = rs End If End Sub Public Sub LoadDatesIntoListBox(frm As Form, strListBoxName As String) Dim rs As Object Dim strRowSource As String Dim ctl As Control Set ctl = frm.Controls(strListBoxName) Set rs = GetSplitDatesRecordset() If rs.EOF Then ctl.RowSource = "" Exit Sub End If Do Until rs.EOF strRowSource = strRowSource & rs!user_id & ";" & Format(rs!SingleDate, "yyyy-mm-dd") & ";" rs.MoveNext Loop ctl.RowSourceType = "Value List" ctl.ColumnCount = 2 ctl.ColumnWidths = "2cm;3cm" ctl.RowSource = strRowSource End Sub ولكن تعتمد على احدى الحيلتين الاولة نموذج مستمر غير منضم به حقلين الاول : txtuserId الثانى: txtSingleDate وعند تحمل النموذج نستخدم الاستدعاء التالى Private Sub Form_Load() Me.txtuserId.ControlSource = "user_id" Me.txtSingleDate.ControlSource = "SingleDate" LoadDatesIntoForm Me End Sub الحيلة الثانية نموذج غير منضم به مربع قيم مثلا باسم : lstDates وعند تحمل النموذج نستخدم الاستدعاء التالى Private Sub Form_Load() LoadDatesIntoListBox Me, "lstDates" End Sub هذا كل ما خطر على بالى من افكار

اذا الموضوع اسهل الان بوجود هذا الجدول المساعد مباشرة وبدون اى اكواد ممكن عمل الاستعلام التالى SELECT tbl1.user_id, tbl2.dateField FROM tbl1, tbl2 WHERE (((tbl2.dateField) Between [tbl1].[startA] And [tbl1].[endA])) ORDER BY tbl1.user_id, tbl2.dateField; ممكن الجدول المساعد tbl2 يتم عمل البيانات بداخله ديناميكا ليحتوى على كل تواريخ العام منذ بداية العام الى نهايته مثلا من خلال الكود التالى Public Sub PopulateDateTable(Optional ByVal dtmStartDate As Date = 0, Optional ByVal dtmEndDate As Date = 0) Dim db As DAO.Database Dim rs As DAO.Recordset Dim dtmDate As Date Dim lngYearNow As Long ' الحصول على السنة الحالية lngYearNow = Year(Date) ' تعيين القيم الافتراضية إذا لم يتم تمريرها If dtmStartDate = 0 Then dtmStartDate = DateSerial(lngYearNow, 1, 1) If dtmEndDate = 0 Then dtmEndDate = DateSerial(lngYearNow, 12, 31) ' التأكد أن التاريخين صالحين If dtmStartDate > dtmEndDate Then MsgBox "تاريخ البداية أكبر من تاريخ النهاية!", vbExclamation Exit Sub End If Set db = CurrentDb ' مسح البيانات القديمة db.Execute "DELETE FROM tbl2", dbFailOnError ' فتح الجدول للإضافة Set rs = db.OpenRecordset("tbl2", dbOpenDynaset) ' ملء السجلات For dtmDate = dtmStartDate To dtmEndDate rs.AddNew rs!dateField = dtmDate rs.Update Next dtmDate ' تنظيف الموارد rs.Close Set rs = Nothing Set db = Nothing MsgBox "تم توليد التواريخ من " & Format(dtmStartDate, "yyyy-mm-dd") & " إلى " & Format(dtmEndDate, "yyyy-mm-dd"), vbInformation End Sub

برضو بدون جداول ؟؟؟

وعليكم السلام ورحنة الله تعالى وبركاته ممكن من خلال الكود التالى فى وحده نمطية عامة مثلا باسم : basGetDatesBetween Public Function GetDatesBetween(ByVal dtmStartDate As Date, ByVal dtmEndDate As Date) As String If dtmStartDate > dtmEndDate Then GetDatesBetween = "" Exit Function End If Dim dtmCurrentDate As Date Dim arrDates() As String ReDim arrDates(0 To DateDiff("d", dtmStartDate, dtmEndDate)) Dim lngIndex As Long For dtmCurrentDate = dtmStartDate To dtmEndDate arrDates(lngIndex) = Format(dtmCurrentDate, "yyyy-mm-dd") lngIndex = lngIndex + 1 Next dtmCurrentDate GetDatesBetween = Join(arrDates, " | ") End Function على ان يكون الاستدعاء فى الاستعلام لعمل حقل التواريخ بالشكل التالى DateList: GetDatesBetween([startA],[endA]) لتكون جملة الاستعلام كاملة كما يلى SELECT tbl1.user_id, GetDatesBetween([startA], [endA]) AS DateList FROM tbl1; ويمكن خفظ الاستعلام مثلا باسم : qryUserDateList لا اعرف هل الفكرة تلبى الطلب ام لا خطر على بالى ايضا اضفة استعلام جديد يعتمد على الاستعلام السابق لنعط مثلا للاستعلام الجديد اسم : qryFilteredDates وتكون جملة الاستعلام بالشكل التالى SELECT * FROM qryUserDateList WHERE DateList LIKE "*" & Format([InbutFromDate], "yyyy-mm-dd") & "*" OR DateList LIKE "*" & Format([InbutToDate], "yyyy-mm-dd") & "*"; أو مثلا لو أردنا تمرير التواريخ من نموذج SELECT * FROM qryUserDateList WHERE DateList LIKE "*" & Format(Forms!frmSearch!txtFromDate, "yyyy-mm-dd") & "*" OR DateList LIKE "*" & Format(Forms!frmSearch!txtToDate, "yyyy-mm-dd") & "*"; وظيفة الاستعلام الاخير qryFilteredDates أذا كنا نريد البحث في DateList إن كانت تحتوي على أي تاريخ بين النطاقين وذلك لأنه لا يمكن تصفية نتيجة دالة GetDatesBetween بشكل مباشر باستخدام WHERE

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

حلو جدا دمج فكرة الاستاذ @منتصر الانسي Option Compare Database Option Explicit ' ===== متغير عام لتفعيل الطباعة في نافذة Immediate ===== Public DebugMod As Boolean ' =============================================== ' دالة رئيسية: تقوم بعملية DLookup مع دعم المعايير المتعددة ' =============================================== Public Function GenericDLookup( _ ByVal strFieldName As String, _ ByVal strTableName As String, _ ParamArray arrCriteria() As Variant) As Variant On Error GoTo ErrHandler Dim strCriteria As String Dim lngIndex As Long Dim strField As String, strOperator As String Dim varValue As Variant Dim strOneCondition As String Dim db As DAO.Database: Set db = CurrentDb Dim tdf As DAO.TableDef: Set tdf = db.TableDefs(strTableName) ' التحقق من وجود الجدول والحقل الأساسي If Not TableExists(strTableName, db) Then Err.Raise vbObjectError + 517, , "الجدول غير موجود: " & strTableName If Not FieldExists(strFieldName, tdf) Then Err.Raise vbObjectError + 518, , "الحقل غير موجود: " & strFieldName ' التحقق من شكل المصفوفة If (UBound(arrCriteria) + 1) Mod 3 <> 0 Then Err.Raise vbObjectError + 514, , "المعايير يجب أن تكون ثلاثية" For lngIndex = 0 To UBound(arrCriteria) Step 3 strField = CStr(arrCriteria(lngIndex)) strOperator = Trim(UCase(CStr(arrCriteria(lngIndex + 1)))) varValue = arrCriteria(lngIndex + 2) If Not FieldExists(strField, tdf) Then Err.Raise vbObjectError + 519, , "الحقل غير موجود: " & strField Select Case strOperator Case "IS NULL", "IS NOT NULL" strOneCondition = "[" & strField & "] " & strOperator Case "LIKE", "=", "<>", "<", ">", "<=", ">=" strOneCondition = "[" & strField & "] " & strOperator & " " & cSQLSafe(strTableName, strField, varValue, db, tdf) Case "BETWEEN" If IsArray(varValue) And UBound(varValue) = 1 Then strOneCondition = "[" & strField & "] BETWEEN " & _ cSQLSafe(strTableName, strField, varValue(0), db, tdf) & " AND " & _ cSQLSafe(strTableName, strField, varValue(1), db, tdf) Else Err.Raise vbObjectError + 520, , "القيمة لـ BETWEEN يجب أن تكون مصفوفة من عنصرين" End If Case "IN" If IsArray(varValue) Then Dim i As Long, strIN As String For i = LBound(varValue) To UBound(varValue) strIN = strIN & IIf(Len(strIN) > 0, ", ", "") & cSQLSafe(strTableName, strField, varValue(i), db, tdf) Next strOneCondition = "[" & strField & "] IN (" & strIN & ")" Else strOneCondition = "[" & strField & "] = " & cSQLSafe(strTableName, strField, varValue, db, tdf) End If Case "EXISTS" strOneCondition = "EXISTS (" & varValue & ")" Case Else Err.Raise vbObjectError + 515, , "المعامل غير مدعوم: " & strOperator End Select If Len(strCriteria) > 0 Then strCriteria = strCriteria & " AND " strCriteria = strCriteria & strOneCondition Next If DebugMod Then Debug.Print "GenericDLookup Criteria: " & strCriteria GenericDLookup = DLookup(strFieldName, strTableName, strCriteria) Exit Function ErrHandler: If DebugMod Then Debug.Print "خطأ في GenericDLookup: " & Err.Number & " - " & Err.Description GenericDLookup = Null End Function ' =============================================== ' التحقق من وجود الجدول ' =============================================== Private Function TableExists(TableName As String, db As DAO.Database) As Boolean On Error Resume Next Dim tdf As DAO.TableDef: Set tdf = db.TableDefs(TableName) TableExists = Not tdf Is Nothing On Error GoTo 0 End Function ' =============================================== ' التحقق من وجود الحقل داخل الجدول ' =============================================== Private Function FieldExists(FieldName As String, tdf As DAO.TableDef) As Boolean On Error Resume Next Dim fld As DAO.Field: Set fld = tdf.Fields(FieldName) FieldExists = Not fld Is Nothing On Error GoTo 0 End Function ' =============================================== ' تنسيق القيمة حسب نوع الحقل لاستخدامها داخل SQL ' =============================================== Public Function cSQLSafe(strTable As String, strField As String, varValue As Variant, _ Optional db As DAO.Database = Nothing, Optional tdf As DAO.TableDef = Nothing) As String On Error GoTo HandleError If db Is Nothing Then Set db = CurrentDb If tdf Is Nothing Then Set tdf = db.TableDefs(strTable) Dim fld As DAO.Field: Set fld = tdf.Fields(strField) Dim intType As Integer: intType = fld.Type If IsNull(varValue) Then cSQLSafe = "NULL": Exit Function Select Case intType Case dbText, dbMemo, dbGUID cSQLSafe = "'" & Replace(CStr(varValue), "'", "''") & "'" Case dbDate Dim dtm As Date If TryParseAnyDate(varValue, dtm) Then cSQLSafe = "#" & Format(dtm, IIf(TimeValue(dtm) = 0, "yyyy-mm-dd", "yyyy-mm-dd hh:nn:ss")) & "#" Else cSQLSafe = "NULL" End If Case dbBoolean cSQLSafe = IIf(varValue, "-1", "0") Case dbByte, dbInteger, dbLong, dbSingle, dbDouble, dbCurrency, dbDecimal If IsNumeric(varValue) Then cSQLSafe = Replace(Format(CDbl(varValue), "0.########"), ",", ".") Else cSQLSafe = "NULL" End If Case Else cSQLSafe = "NULL" End Select Exit Function HandleError: If DebugMod Then Debug.Print "[cSQLSafe] خطأ: " & Err.Number & " - " & Err.Description cSQLSafe = "NULL" End Function ' =============================================== ' دالة تحويل أي تنسيق تاريخ إلى قيمة صالحة ' =============================================== Public Function TryParseAnyDate(ByVal strInput As Variant, ByRef dtmOut As Date) As Boolean On Error GoTo Fail If IsNull(strInput) Then GoTo Fail If IsDate(strInput) Then dtmOut = CDate(strInput): TryParseAnyDate = True: Exit Function Dim parts() As String, dd As Integer, mm As Integer, yyyy As Integer Dim timePart As String, strClean As String strClean = Trim(CStr(strInput)) If InStr(strClean, " ") > 0 Then parts = Split(strClean, " ") strClean = parts(0) If UBound(parts) > 0 Then timePart = parts(1) End If strClean = Replace(Replace(strClean, "/", "."), "-", ".") parts = Split(strClean, ".") If UBound(parts) = 2 Then dd = Val(parts(0)): mm = Val(parts(1)): yyyy = Val(parts(2)) If yyyy < 100 Then yyyy = yyyy + IIf(yyyy < 30, 2000, 1900) If mm > 12 Then Dim tmp As Integer tmp = dd dd = mm mm = tmp End If If IsDate(DateSerial(yyyy, mm, dd)) Then dtmOut = DateSerial(yyyy, mm, dd) If Len(timePart) > 0 And IsDate(timePart) Then dtmOut = dtmOut + TimeValue(timePart) TryParseAnyDate = True Exit Function End If End If Fail: TryParseAnyDate = False End Function الاستدعاء Dim varResult As Variant varResult = GenericDLookup("date2", "tbl2", _ "date2", "=", Me.text1, _ "usr_id", "=", Me.text2 _ ) If IsNull(varResult) Then MsgBox "لا توجد نتيجة" Else MsgBox varResult End If

اذا السؤال الان هل لو الاستعلام معقد ويعالج العديد من البيانات اذا تتم المعالجة مع كل دفعة اذا الافضل مع هذه الحالات محاولة التحايل بطريقة ما لتحميل البيانات دفعة واحدة لتطبيق كافة العمليات

جزاكم الله خيـــــــــرا استاذى والان تعلمت شئ جديد وتم تصحيح معلومة مغلوطة لدى

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

بعد اذن استاذى الجليل و معلمى القدير تجربة عملية: أضف Debug.Print ID داخل دالة Add_One افتح الاستعلام ولا تعرض سجلات اخرى افتح محرر الاكواد وانظر الى النتيجة تجد انه تم معالجة كل البيانات دفعة واحده تجربة عملية رقم (2) اعتذر عندى مشكلة لا استطيع اضافة اى مرفقات من فضلك قك بانشاء جدولا من خلال الاستعلام التالى CREATE TABLE tblFunctionCalls ( ID AUTOINCREMENT PRIMARY KEY, FunctionName TEXT(50), CallTime DATETIME, Param1 DOUBLE, Param2 DOUBLE, ResultValue DOUBLE, ContextInfo TEXT(100) ); انظر الى الكود التالى بتعديل بسيط Public Function Add_One(lngID As Long, dblN As Double) As Double Dim dblResult As Double dblResult = dblN + 1.5 If lngID = 55 Then dblResult = 55 End If ' تسجيل الاستدعاء في الجدول On Error Resume Next CurrentDb.Execute "INSERT INTO tblFunctionCalls (FunctionName, CallTime, Param1, Param2, ResultValue, ContextInfo) " & _ "VALUES ('Add_One', Now(), " & lngID & ", " & dblN & ", " & dblResult & ", '" & Nz(Application.CurrentObjectName, "Unknown") & "')" On Error GoTo 0 Add_One = dblResult End Function الان قم بفتح الاستعلام ولا تحرك الشاشة ولا تعرض اى سجلات اغلق الاستعلام انظر الى الجدول

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

انا عجبتنى الافكار بس اضفت بعض البهارات للطبخة اتمنى لكم مذاقا هنيئا Option Compare Database Option Explicit Public DebugMode As Boolean Public Sub ExportImagesToPdf( _ Optional blnShowImageNames As Boolean = True, _ Optional blnAddPageNumbers As Boolean = True, _ Optional strPdfName As String = "", _ Optional strFolderSource As String = "", _ Optional strFolderTarget As String = "" _ ) Dim strPdfPath As String Dim objFSO As Object, objFolder As Object, objFile As Object Dim objWordApp As Object, objDoc As Object, objRange As Object, objImg As Object Dim colFiles As Collection, arrFiles() As String Dim lngImgCount As Long, i As Long Dim fd As Object On Error GoTo ErrHandler ' اختيار مجلد الصور إذا لم يُمرر If Trim(strFolderSource) = "" Then Set fd = Application.FileDialog(4) With fd .Title = "اختر المجلد الذي يحتوي على الصور" If .Show <> -1 Then If DebugMode Then Debug.Print "تم إلغاء اختيار مجلد الصور." Exit Sub End If strFolderSource = .SelectedItems(1) End With End If If Right(strFolderSource, 1) <> "\" Then strFolderSource = strFolderSource & "\" If DebugMode Then Debug.Print "مجلد الصور: " & strFolderSource ' التحقق من وجود مجلد الصور If Dir(strFolderSource, vbDirectory) = "" Then MsgBox "مجلد الصور غير موجود", vbCritical + vbMsgBoxRight Exit Sub End If ' اختيار مجلد الهدف إذا لم يُمرر If Trim(strFolderTarget) = "" Then Set fd = Application.FileDialog(4) With fd .Title = "اختر المجلد لحفظ ملف PDF" If .Show <> -1 Then If DebugMode Then Debug.Print "تم إلغاء اختيار مجلد الهدف." Exit Sub End If strFolderTarget = .SelectedItems(1) End With End If If Right(strFolderTarget, 1) <> "\" Then strFolderTarget = strFolderTarget & "\" If Dir(strFolderTarget, vbDirectory) = "" Then MkDir strFolderTarget If DebugMode Then Debug.Print "تم إنشاء مجلد الهدف: " & strFolderTarget End If ' إعداد اسم ملف PDF If Trim(strPdfName) = "" Then strPdfPath = strFolderTarget & "صور_المجلد_" & Format(Now(), "yyyy-mm-dd_hh-mm-ss") & ".pdf" Else strPdfPath = strFolderTarget & strPdfName & ".pdf" End If If DebugMode Then Debug.Print "مسار ملف PDF: " & strPdfPath ' جمع الصور Set colFiles = New Collection Set objFSO = CreateObject("Scripting.FileSystemObject") Set objFolder = objFSO.GetFolder(strFolderSource) For Each objFile In objFolder.Files If LCase(objFile.Name) Like "*.jpg" Or LCase(objFile.Name) Like "*.jpeg" Or _ LCase(objFile.Name) Like "*.png" Or LCase(objFile.Name) Like "*.bmp" Or _ LCase(objFile.Name) Like "*.gif" Then colFiles.Add objFile.Path lngImgCount = lngImgCount + 1 If DebugMode Then Debug.Print "تم العثور على صورة: " & objFile.Path End If Next If lngImgCount = 0 Then MsgBox "لا توجد صور في المجلد المحدد", vbExclamation + vbMsgBoxRight GoTo CleanExit End If ' تحويل الـ Collection إلى مصفوفة ReDim arrFiles(0 To lngImgCount - 1) For i = 1 To colFiles.Count arrFiles(i - 1) = colFiles(i) Next ' فرز الصور Call SortArray(arrFiles) If DebugMode Then Debug.Print "تم فرز الصور" ' إنشاء مستند Word Set objWordApp = CreateObject("Word.Application") Set objDoc = objWordApp.Documents.Add objWordApp.Visible = False With objDoc.PageSetup .Orientation = 0 .TopMargin = 28 .BottomMargin = 28 .LeftMargin = 28 .RightMargin = 28 End With ' إضافة ترقيم الصفحات (إذا تم اختياره) If blnAddPageNumbers Then With objDoc.Sections(1).Footers(1).PageNumbers .Add 1, True .NumberStyle = 0 ' wdNumberStyleArabic With .Parent.Range .ParagraphFormat.Alignment = 1 ' توسيط .Font.Size = 8 .Font.Color = RGB(100, 100, 100) End With End With End If ' إدراج الصور For i = 0 To UBound(arrFiles) Set objRange = objDoc.Range objRange.Collapse 0 If i > 0 Then objRange.InsertBreak 2 objRange.Collapse 0 End If ' إدراج الصورة objRange.ParagraphFormat.Alignment = 1 Set objImg = objRange.InlineShapes.AddPicture(arrFiles(i), False, True) With objImg .LockAspectRatio = True If .Width > 500 Or .Height > 650 Then If .Width / .Height > 500 / 650 Then .Width = 500 Else .Height = 650 End If End If End With ' إضافة اسم الملف أسفل الصورة (إذا تم اختياره) If blnShowImageNames Then Set objRange = objDoc.Range objRange.Collapse 0 objRange.InsertAfter vbCrLf & Mid(arrFiles(i), InStrRev(arrFiles(i), "\") + 1) With objRange .ParagraphFormat.Alignment = 1 .ParagraphFormat.SpaceAfter = 6 .Font.Size = 9 .Font.Color = RGB(120, 120, 120) End With End If If DebugMode Then Debug.Print "تم إدراج الصورة: " & arrFiles(i) Next ' حذف أي فقرات فارغة في بداية المستند While objDoc.Paragraphs.Count > 0 And Trim(objDoc.Paragraphs(1).Range.Text) = "" objDoc.Paragraphs(1).Range.Delete Wend ' حذف فقرة فارغة محتملة في النهاية If objDoc.Paragraphs.Count > 0 Then With objDoc.Paragraphs(objDoc.Paragraphs.Count).Range If Trim(.Text) = "" Then .Delete End With End If ' حفظ كـ PDF objDoc.SaveAs2 strPdfPath, 17 objDoc.Close False objWordApp.Quit MsgBox "تم إنشاء ملف PDF بنجاح:" & vbCrLf & strPdfPath, vbInformation + vbMsgBoxRight CleanExit: Set objDoc = Nothing Set objWordApp = Nothing Set objRange = Nothing Set objImg = Nothing Set colFiles = Nothing Set objFolder = Nothing Set objFSO = Nothing Set fd = Nothing Exit Sub ErrHandler: If DebugMode Then Debug.Print "خطأ: " & Err.Number & " - " & Err.Description End If MsgBox "حدث خطأ: " & Err.Description, vbCritical + vbMsgBoxRight Resume CleanExit End Sub Private Sub SortArray(ByRef arr() As String) Dim i As Long, j As Long Dim temp As String For i = LBound(arr) To UBound(arr) - 1 For j = i + 1 To UBound(arr) If UCase(arr(i)) > UCase(arr(j)) Then temp = arr(i) arr(i) = arr(j) arr(j) = temp End If Next j Next i End Sub

وتوضيحا فقط وحسب فهمى لقول استاذى الجليل ومعلمى القدير و والدى الحبيب الاستاذ جعفر - الاكسس يعالج فقط السجلات المعروضة على الشاشة (مثلا 30)؟ صحيح فقط في حالة النماذج (Forms) وغير صحيح في حالة فتح الاستعلام مباشرة أو في التقارير أو التصدير الاكسس ينفذ الاستعلام بالكامل ويحسب النتائج لكل السجلات - إذا كان الاستعلام مصدرا لنموذج فلن يكون هناك بطء ملحوظ؟ صحيح إذا لم تستخدم دوال خارجية في حقول يتم عليها فرز/تصفية لو كان هناك: فرز أو تصفية على حقل فيه دالة DLookup أو دالة VBA خارجية أو تحميل بيانات من جدول كبير بدون فهرسة مناسبة - الطباعة لا تسبب بطء لأنها تطبع صفحة صفحة؟ غير دقيق: الاكسس يقوم بتجهيز التقرير بالكامل قبل عرض أول صفحة أي دوال خارجية أو معادلات تحسب على كل السجلات قبل العرض والطباعة - لا يوجد بطء عند استخدام دوال خارجية إذا لم تكن هناك عمليات فرز أو تصفية؟ صحيح تماما في حالة: استخدام الاستعلام كمصدر نموذج أو عرض النتائج فقط دون فرز/تصفية على الحقول التي تنادي دوال خارجية لكن عند فتح الاستعلام مباشرة أو فرز/تصفية الحقول المحسوبة الاكسس يجبر على حساب القيم لكل السجلات ردودى السابقة لتحليل فهمى لمشاركة الاستاذ جعفر حسب فهمى ومعلوماتى الشخصية وان كان فهمى خاطى أنتظر التصحيح من اساتذتى العظماء

الاكسس يقوم بحساب السجلات المعروضة على الشاشة فقط عندما يكون ذلك داخل نموذج وليس داخل استعلام هذا حسب فهمى المتواضع قد اكون مخطئ. ربما هذا الظاهر فقط الان ولكن انا دائما مع الاستعلامات اعمل وفق هذه القاعدة الذهبية دائما الأولوية للمنطق المباشر أفضل من الاعتماد على الحيل النصية عند فتح استعلام مباشرة (Query View أو من الكود) Access يقوم بتحميل كل السجلات دفعة واحدة وليس فقط الظاهرة على الشاشة يعني: سواء كان عندك 100 أو 1000,000 سجل وسواء كان حجم الشاشة يعرض 30 فقط او حتى 10 بمجرد فتح الاستعلام مباشرة (من نافذة Access أو من الكود) يقوم Access بتنفيذ الاستعلام بالكامل من البداية إلى النهاية ويحسب ويقوم بمعالجة البيانات فى كل الأعمدة بما فيها الدوال مثل DLookup أو أي دوال خارجية ثم يظهر أول 30 سجل فقط او اول 10 سجلات حسب حجم الشاشة لكن المعالجة تمت لكل السجلات بالفعل

السلام عليكم طبعا وبادئ ذى بدئ اخى موسي فوق راسي وردى التالى ليس تقليلا او شئ من هذا القبيل اطلاقا ولكن فقط هذه وجهة نظرى قد اكون محطئ فيها وقد أصيب احل اخى موسي يبدو الطف فى الشكل الظاهرى ولكن ليس بالضرورة أخف تعتمد طريقة اخى موسى على انشاء سلسلة نصية و معالجة النص باستخدام (InStr وIIf) مما قد يكون بطئ نسبيا مع مرور الوقت وبالأخص مع وجود بيانات كبيرة بينما تعتمد طريقتى المتواضعة على استخدام شروط منطقية صريحة (AND - OR - NOT) والتى بدورها سوف تكون اسرع مع محرك الاستعلام لان التحقق يتم على القيم مباشرة دون تكوين سلاسل أو بحث نصي قاعدة ذهبيه مع الاستعلامات : دائما الأولوية للمنطق المباشر أفضل من الاعتماد على الحيل النصية

SELECT tblNames.UserId, tblNames.s_name, tblDays.day_id, tblDays.dayNm FROM tblDays, tblNames WHERE tblNames.UserId = [Forms]![Form1]![Combo0] AND ( (tblDays.day_id = 1 AND NOT tblNames.chekVuc1) OR (tblDays.day_id = 2 AND NOT tblNames.chekVuc2) OR (tblDays.day_id = 3 AND NOT tblNames.chekVuc3) OR (tblDays.day_id = 4 AND NOT tblNames.chekVuc4) OR (tblDays.day_id = 5 AND NOT tblNames.chekVuc5) OR (tblDays.day_id = 6 AND NOT tblNames.chekVuc6) OR (tblDays.day_id = 7 AND NOT tblNames.chekVuc7) ); اعتذر عندى مشكلة بالانترنت لا استطيع رفع مرفقات استاذى الجليل ومعلمى القدير و والدى الحبيب لا اعرف هل الافكار فى هذا الموضوع مشابهه ام تساعد فى تحقيق اى من اهدافكم الحالية او المستقبلية ام لا ولكن احسست بوجه شبه من بعيد او من قريب بينهم

Public Function MultiplyTime(strTime As String, factor As Double) As String On Error GoTo ErrHandler Dim totalMinutes As Double totalMinutes = TimeValue(strTime) * 24 * 60 * factor MultiplyTime = Format(totalMinutes / 24 / 60, "hh:nn") Exit Function ErrHandler: MultiplyTime = "خطأ في الوقت" End Function وللاستدعاء MultiplyTime("4:30", 5)