Foksh

وعليكم السلام ورحمة الله وبركاته..

مشاركتكم الأفكار ، بأن تكون الدالة معتمدة على الـ Tag بالإضافة الى الجدول ( أو بدونه بتضمين اللون في الاستدعاء ) ، بحيث كل مجموعة عناصر مشتركة في Tag واحد تأخذ نفس اللون بغض النظر عن موقعها !!

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

3 ساعات مضت, عبدالله المجرب said:

الف مبروك للاستاذ فادي الترقية المستحقة

بارك الله بكم استاذي الفاضل 😇..

شكراً لك 💐

8 ساعات مضت, ابوخليل said:

حسب انظمتهم  من وقع حضور ولم يوقع انصراف يعتبر غائبا

ماذا لو حصل خلل أو انقطاع الكهرباء أو تلف ... الخ !!!!

رغم أنك وأعتقد ذلك من خلال المكتبات أنك أسست للربط بجهاز البصمة ، فهل الخلل الحاصل سيتحمله الموظف ويدخل في متاهة أثبت أو إحلف 😅 ..... الخ.

ما لم تكن هناك حلول لهذه الإحتمالات قد تم أخذها في الحسبان ، فرأيي أن الأنظمة التي يقود مركبها جهاز قابل للخطأ = غير عادلة.

أشعر انني انفعلت قليلاً 🤣😂

هي وجهة نظر ما لم يكن معلمي قد خبأ لنا إجابة تنتظر هذا التعليق .

الأكواد جميلة جدا ، وفكرتها جميلة وقد ألمت بجميع النواحي البرمجية التي تحدثتم عنها سابقاً.

6 ساعات مضت, Hamtoooo said:

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

الحمد لله على نعمه..

لا تنسى إغلاق الموضوع أخي الكريم 🤗 

3 ساعات مضت, ابو جودي said:

وعليكم السلام ورحمة الله تعالى وبركاته

جزاكم الله خيـــــــرا
اسال الله تعالى ان يعفو ويغفر لوالدك و والدى ويرحمهم رحمة واسعة وكل المسلمين الاحياء منهم والاموات وان يسكنهم الفردوس الاعلى ان شاء الله

تسلم ايدك يا فنان

حبيبي يا هندسة 🤗

اللهم تقبل دعائكم بظهر الغيب 🤲🏻

3 ساعات مضت, Lamyaa said:

شكرا على المشاركة ورحم الله والديك

شكراً لمرورك اختنا الكريمة ،، ولكم من الدعاء النصيب الأكبر 😇

6 دقائق مضت, mohammed farhat said:

جزاكم الله كل خير بشمهندس فادي هدية أكثر من رائعة 

وإياكم أخي الكريم .. 

شكراً لمرورك العطر 

كثيرون استفسروا عن كيفية اختيار اسم مخزن في الجدول ، بدلاً من كتابة الرقم بشكل يدوي .

ولذا قد صورت هذا الفيديو كفكرة سريعة على الخطوات - وصولاً إلى النتيجة ,,

طبعاً كلمة كثيرون = في مجموعة الواتس أب الخاصة بقسم آكسيس 

وليس في المنتدى 🤣

وعليكم السلام ورحمة الله وبركاته ،،

وبما اني اتابع من الجوال ، ولم استطع من رؤية الملف . اعتقد ان هناك أكثر من فكرة !!!

الأولى قد تعتمد على دالة تتفقد جميع العناصر ذات النوع "مربع نص" بأنها تحتوي قيم وغير فارغة . وهذا قد يسبب مشكلة لأنه حينها لن يميز بين مربعات النص التي تريدها من مربعات نص أخرى على سبيل المثال .

الثانية أنه عند الحفظ وقبل إتمام عملية الحفظ التأكد من مربعات النص التي لها مصدر بيانات مرتبط بحقل وليس مربعات النص الغير مضمنة بمصدر بيانات ، وهنا قد تكون مشكلة أيضاً .

الثالثة وما أرجحها بشكل أفضل وأقوى ، وهو من خلال الـ TAG . بحيث تضع وسماً لجميع مربعات النص التي تريدها أن يتم التحقق منها ولنفترض = Ham

حيث من خلال زر الحفظ نستعمل كود بهذا الشكل تقريباً - ما لم أكن مخطئاً في بعض الأجزاء ..

dim ctl as control, missing as string
for each ctl in me.controls
if lcase(trim(ctl.tag)) = "Ham" then
if nz(ctl.value, "") = "" then
missing = missing & vbcrlf & ctl.name
end if
end if
next
if missing <> "" then
msgbox " :  الحقول التالية فارغة" & vbcrlf & missing, vbinformation+ vbmsgboxright, ""
exit sub
end if
docmd.runcommand accmdsaverecord
docmd.gotorecord,,acnewrec

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

بكل الأحوال جرب وأخبرنا بالنتيجة ، عل أحد الأساتذة والأخوة يتابع معك من كمبيوتر 🥴

على كل حال جرب 

خطر على بالي نقطة أخرى من خلال السطر :-

missing = missing & vbcrlf & ctl.name

بأن نستبدله بالسطر التالي :-

missing = missing & vbcrlf & ctl.controls(0).caption

فهنا سيأقرأ التسمية ( label ) المرتبطة بكل مربع نص بدلاً من اسم مربع النص نفسه .

أخواني وأساتذتي ومعلمينا ( دون استثناء )

أعتقد أنه ومن خلال العنوان سيتسائل البعض عن أن المحاولات كانت كثيرة لبناء هذه الفكرة ولكنها مع التحديثات الجديدة تفشل !!

وهذا الإعتقاد منطقي 😁 . إلا انه وبهذه التحديثات - واتمنى - أنه قد تم التعامل مع هذه الأخطاء بهذه النسخة المطورة والمحسنة .

 الإضافات التي تم تأمينها في هذه النسخة :-

     التعامل مع المرفقات بسلاسة وسهولة من خلال فكرة نسخ المرفق ولصقه في تطبيق الواتس اب ( سطح المكتب ) ، وليس من خلال المسار 😁 .

     إمكانية الإرسال لأكثر من رقم دفعة واحدة . افصل بين الرقمين بإشارة / فقط .

     إمكانية إضافة التعبيرات Emoji وإرسالها ضمن الرسائل في الواتس أب . من خلال زر 

     زر لمسح محتوى الرسالة تهيئةً لإرسال جديد . من خلال الزر 

     تضمين محدد لحجم الملفات والمرفقات المرسلة . ( خاص بأصحاب التطويرات الذين يريدون تقييد وإلزام المستخدم بحجم محدد ) .

     استخدام تايمر متغير للتعامل مع الإرسالات المتعددة لأكثر من رقم .

     واجهة محاكية وجذابة للبرنامج .

     لا تحتاج جداول أو مكتبات خارجية .... إلخ .

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

 واجهة البرنامج :-

:-

      ضرورة تثبيت برنامج واتس اب سطح المكتب من متجر ويندوز .

      التأكد من فتح تطبيق الواتس أب سطح المكتب لديك ، لتلافي المشاكل عند اختلاف سرعة إستجابة الكمبيوتر من مستخدم لآخر .

WhatsApp Sender 2025.zip

الان, ابو جودي said:

ما هو لو حد رخم زى حلاتى ممكن يكون عامل حماية للمجلد من حذف ما فيه 

تعملها ويطلع منك 

1 ساعه مضت, ابو جودي said:

طيب كنت قد كتبت داله تعتمد على تشفير : MD5

تفتكر هيكون آمن إذا استخدم لوحده بدون ( Salt ) ؟؟

وحبة الملح دي هي اللي ممكن تزيد من مستوى الحماية في كلمات المرور ..

منذ ساعه, شايب said:

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

 

ننتظر عودتكم بموضوع منفصل للإفادة 😇

منذ ساعه, شايب said:

مع ان مثل هذه المشاركات لا تجد القبول او الاهتمام من بعض الاعضاء وتمر مرور الكرام

 

للأسف مع تحفظي ، الكثير من المواضيع يُـمَـرُّ عليها مرور الكرام ... 😅

منذ ساعه, شايب said:

فمن خبرة سنوات طويلة نسبة كبيرة من المبرمجين تهتم بامن البرنامج اكثر من اهتمامها بامن البيانات

 

نعم صحيح ، وانا كنت أحدهم على فكرة هههههه

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

دمتم بخير 😇

اولا ، وعليكم السلام ورحمة الله وبركاته 🤗 

اخي الكريم ،

اهتمامك بمواضيعك من حيث العنوان الصحيح والمناسب يساعدك لاحقاً على أن تجد المساعدة بشكل أسرع .

على العموم ، اذا كان اصدار الويندوز الذي تم تثبيته = ويندوز 10 أو أحدث ، فراجع هذا الرابط من بدايته ..

وعليكم السلام ورحمة الله وبركاته 🤗 

أخي الكريم فعلاً الكثير من المواضيع التي تحدثت عن هذه المشكلة ،،

حاول رفع ملفك على جوجل درايف أو mediafire  ، وارسل الرابط.

13 دقائق مضت, شايب said:

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

 

ما شاء الله ، مبدع فيما طرحت .

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

ومن سياق الحديث الذي طرحته ، اعتقد أن استخدام المعلمات بدلاً من سلاسل نصية سيكون من خطوات الأمان التي قد يجب تنفيذها .

أيضاً على ما أعتقد استخدامنا لمطهرات النصوص قد يأتي بنتيجة جيدة ومساعدة ,,

على سبيل المثال ، هذه فكرة بسيطة أيضاً وقد تكون قابلة للتطوير والتحديث بشمولية ,,

If InStr(Me.txtUser, "'") > 0 Or InStr(Me.txtUser, ";") > 0 Then
    MsgBox "تم استخدام رموز غير مسموح بها في اسم المستخدم", vbExclamation
    Exit Sub
End If

ولهذا السبب كنت قد استخدمت محاولة لم أقم بتجربتها بعد ، على أحد المشاريع باستخدام هذه الدالة :-

Public Function Sanitizer(ByVal userInput As String, Optional ByVal context As String = "sql") As String
    Dim sanitized As String
    sanitized = Trim(userInput)
    
    Select Case LCase(context)
        Case "sql"
            sanitized = Replace(sanitized, "'", "''")
            sanitized = Replace(sanitized, ";", "")
            sanitized = Replace(sanitized, "--", "")
        
        Case "name"
            sanitized = Replace(sanitized, "'", "")
            sanitized = Replace(sanitized, ";", "")
            sanitized = Replace(sanitized, "*", "")
            sanitized = Replace(sanitized, "=", "")
        
        Case "pure"
        
        Case Else
            sanitized = Replace(sanitized, "'", "''")
    End Select

    Sanitizer = sanitized
End Function

وعلى سبيل المثال كإستخدام في الاستعلامات :-

Dim filter As String
filter = "[U_UserName]='" & Sanitizer(Me.txtUser, "sql") & "' AND [U_Password]='" & Sanitizer(Me.txtPass, "sql") & "'"
DoCmd.OpenForm "frmDashboard", , , filter

وكمثال على ما طرحته سابقاً لفتح نموذج بفلترة ..

DoCmd.ApplyFilter , "[U_UserName]='" & Sanitizer(Me.txtSearch, "sql") & "'"

أو حتى في نموذج تسجيل الدخول لاسم المستخدم ، كانت المحاولة :-

Dim newUser As String
newUser = Sanitizer(Me.txtNewUser, "name")

هذه كانت الفكرة التي خطرت لي ، ولكن لاحقاً قمت بتحديثها لإظهار رسالة تحذيرية تلقائية إذا تم رصد مدخل خطير أو محاولات حقن نصية 😁

منذ ساعه, محمد عبد الناصر said:

ثم يقوم بنسخ شيت NEW وفتح شيت جديد  باسم الخليه B2 في شيت Main وان امكن ان يعمل ربط تشعبي 

 

وعليكم السلام ورحمة الله وبركاته ..

في مرفقك ، الورقة "MD1 15-2020-16" موجودة في الأساس ، وأنت تريد ترحيل البيانات اليها مسبقاً ، ثم تريد انشاء نسخة من الورقة Main بنفس الاسم الموجود في الخلية B2 في Main صحيح !!!!

وضحها اذا سمحت 😅

8 ساعات مضت, Abaas said:

للرفع

تفضل أخي الكريم ، محاولتي البسيطة . حيث في الورقة الثانية = موقف الغياب اليومي ، قمت بإضافة زر للتحديث ، وتم استدعاءه للدالة التي تم انشاؤها في مديول عام :-

Sub ExtractAbsentEmployees()
    Dim wsMain As Worksheet
    Dim wsReport As Worksheet
    Dim targetDate As Date
    Dim dayNum As Integer
    Dim targetCol As Integer
    Dim lastRow As Long
    Dim i As Long
    Dim reportRow As Long
    
    Set wsMain = ThisWorkbook.Sheets("MainSheet")
    Set wsReport = ThisWorkbook.Sheets("موقف الغياب اليومي")
    
    wsReport.Range("A5:D" & wsReport.Rows.Count).ClearContents
    
    targetDate = wsReport.Range("C2").Value
    dayNum = Day(targetDate)
    
    targetCol = 3 + dayNum
    
    If targetCol < 4 Or targetCol > 34 Then
        MsgBox ".تاريخ غير صالح يجب أن يكون اليوم بين 1 و 31", vbExclamation
        Exit Sub
    End If
    
    lastRow = wsMain.Cells(wsMain.Rows.Count, "B").End(xlUp).Row
    
    reportRow = 5
    
    For i = 4 To lastRow
        If wsMain.Cells(i, targetCol).Value = "غ" Then
            wsReport.Cells(reportRow, 1).Value = wsMain.Cells(i, 1).Value
            wsReport.Cells(reportRow, 2).Value = wsMain.Cells(i, 2).Value
            wsReport.Cells(reportRow, 3).Value = wsMain.Cells(i, 3).Value
            wsReport.Cells(reportRow, 4).Value = targetDate
            reportRow = reportRow + 1
        End If
    Next i
    
    If reportRow = 5 Then
        MsgBox "لا يوجد موظفين متغيبين في هذا التاريخ", vbInformation
    End If
End Sub

وفي الورقة الثالثة "موقف الغياب الشهري" ، أيضاً تم انشاء زر لاستدعاءه الدالة التالية من نفس المديول :-

Sub GenerateMonthlyAbsenceReport()
    Dim wsMain As Worksheet
    Dim wsReport As Worksheet
    Dim startDate As Date, endDate As Date
    Dim currentDate As Date
    Dim dayNum As Integer, targetCol As Integer
    Dim lastRow As Long, reportRow As Long, i As Long
    Dim empName As String, empJob As String
    Dim dateList As String, dayList As String
    Dim dateCount As Integer
    Dim dayName As String
    
    Set wsMain = ThisWorkbook.Sheets("MainSheet")
    Set wsReport = ThisWorkbook.Sheets("موقف الغياب الشهري")
    
    If Not IsDate(wsReport.Range("C2").Value) Or Not IsDate(wsReport.Range("C3").Value) Then
        MsgBox "الرجاء إدخال تاريخين صالحين في الخلايا C2 و C3", vbExclamation + vbMsgBoxRight, ""
        Exit Sub
    End If
    
    startDate = wsReport.Range("C2").Value
    endDate = wsReport.Range("C3").Value
    
    If startDate > endDate Then
        MsgBox "خطأ: تاريخ البداية يجب أن يكون قبل تاريخ النهاية", vbExclamation + vbMsgBoxRight, ""
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    With wsReport
        .Range("A6:F" & .Rows.Count).ClearContents
        .Range("6:" & .Rows.Count).RowHeight = 15
    End With
    
    lastRow = wsMain.Cells(wsMain.Rows.Count, "B").End(xlUp).Row
    reportRow = 6
    
    For i = 4 To lastRow
        empName = wsMain.Cells(i, 2).Value
        empJob = wsMain.Cells(i, 3).Value
        
        If empName = "" Then GoTo NextEmployee
        
        dateList = ""
        dayList = ""
        dateCount = 0
        
        currentDate = startDate
        Do While currentDate <= endDate
            dayNum = Day(currentDate)
            targetCol = 3 + dayNum
            
            If targetCol >= 4 And targetCol <= 34 Then
                If wsMain.Cells(i, targetCol).Value = "غ" Then
                    dayName = wsMain.Cells(2, targetCol).Value
                    
                    If dateList <> "" Then
                        dateList = dateList & vbLf & Format(currentDate, "yyyy-mm-dd")
                        dayList = dayList & vbLf & dayName
                    Else
                        dateList = Format(currentDate, "yyyy-mm-dd")
                        dayList = dayName
                    End If
                    dateCount = dateCount + 1
                End If
            End If
            
            currentDate = DateAdd("d", 1, currentDate)
        Loop
        
        If dateCount > 0 Then
            With wsReport
                .Cells(reportRow, 1).Value = reportRow - 5
                .Cells(reportRow, 2).Value = empName
                .Cells(reportRow, 3).Value = empJob
                .Cells(reportRow, 4).Value = dateCount
                .Cells(reportRow, 5).Value = dateList
                .Cells(reportRow, 6).Value = dayList
                
                .Cells(reportRow, 5).WrapText = True
                .Cells(reportRow, 6).WrapText = True
                
                If dateCount > 1 Then
                    .Rows(reportRow).RowHeight = 15 * dateCount
                End If
            End With
            
            reportRow = reportRow + 1
        End If
        
NextEmployee:
    Next i
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
    If reportRow > 6 Then
'        MsgBox "تم إنشاء التقرير بنجاح", vbInformation + vbMsgBoxRight, ""
    Else
        MsgBox "لا توجد أيام غياب في الفترة المحددة", vbInformation + vbMsgBoxRight, ""
    End If
End Sub

وتركت لك التعديل متاحاً من خلال تحديد الصف أو العمود ... إلخ . وهذا ملفك بعد التعديل . راجعه وأخبرنا بالنتيجة  ..

موقف غياب موظفين.zip

تحويل الدالة الى دالة عامة ، يتم استدعائها في أي نموذج ، توسيع الفكرة

اختيار التاريخ لا يعمل بشيت b-c-d.xlsm

ملاحظة مهمة ، يجب ان يكون الـ CheckBox بجانب الخلية المستهدف إدرا الوقت والتاريخ فيها . أي على يسار الخلية

وإذا كانت الخلية المستهدفة على اليسار ، نقوم باستبدال الجزء

+1

الى

-1

في الدالة داخل المديول

قد سبقني السباقون الأساتذة .. ما شاء الله عليهم ..

عذراً للتأخر في الرد ، ولكن يبدوا أنهم قد أجادوا بما طرحوا ، ويسعدني نقلك للإجابة لأي حل آخر تراه مناسباً لك ( بصدر رحب طبعاً )  .

2 ساعات مضت, ابوخليل said:

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

 

معلمي الفاضل ، اعتذر عن التأخر بالرد ، ولكن فعلاً تفاجأة بضيوفي من العائلة 😅

ولوقت متأخر لم أتمكن من المتابعة ,,

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

على العموم بانتظار مرفقك المعدل ، ومتابع معك  .

وعليكم السلام ورحمة الله وبركاته ,,

حاولت فهم المطلوب بشكل واضح ، وخرجت بهذه الفكرة . حيث انشأت زر للتنفيذ ، يحتوي الكود التالي :-

Private Sub Btn_1_Click()
    Dim wsMain As Worksheet
    Dim wsTarget As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim targetCol1 As String, targetCol2 As String
    Dim sourceCol1 As String, sourceCol2 As String
    
    Set wsMain = ThisWorkbook.Sheets("F")
    
    Dim targetSheetName As String
    targetSheetName = wsMain.Range("F6").Value
    
    On Error Resume Next
    Set wsTarget = ThisWorkbook.Sheets(targetSheetName)
    On Error GoTo 0
    
    If wsTarget Is Nothing Then
        MsgBox " : الورقة المحددة غير موجودة" & targetSheetName, vbExclamation + vbMsgBoxRight, ""
        Exit Sub
    End If
    
    If wsMain.Range("G6").Value = "قوى" Then
        sourceCol1 = "L"
        sourceCol2 = "M"
        targetCol1 = "H"
        targetCol2 = "I"
    ElseIf wsMain.Range("G6").Value = "تامين" Then
        sourceCol1 = "O"
        sourceCol2 = "P"
        targetCol1 = "H"
        targetCol2 = "I"
    Else
        MsgBox "يجب اختيار 'قوى' أو 'تامين' في الخلية G6", vbExclamation + vbMsgBoxRight, ""
        Exit Sub
    End If
    
    wsMain.Range("H6:I" & wsMain.Rows.Count).ClearContents
    
    lastRow = wsTarget.Cells(wsTarget.Rows.Count, sourceCol1).End(xlUp).Row
    lastRow = Application.WorksheetFunction.Max(lastRow, wsTarget.Cells(wsTarget.Rows.Count, sourceCol2).End(xlUp).Row)
    
    For i = 6 To lastRow
        If wsTarget.Range(sourceCol1 & i).Value <> "" Then
            wsMain.Range(targetCol1 & (i - 0)).Value = wsTarget.Range(sourceCol1 & i).Value
        End If
        
        If wsTarget.Range(sourceCol2 & i).Value <> "" Then
            wsMain.Range(targetCol2 & (i - 0)).Value = wsTarget.Range(sourceCol2 & i).Value
        End If
    Next i
    
    MsgBox "تم نقل البيانات بنجاح", vbInformation + vbMsgBoxRight, ""
End Sub

جرب المرفق وأخبرنا بالنتيجة ..

BB.zip

لهذا السؤال :-

27 دقائق مضت, ابوخليل said:

لا اعلم هل يكفي ربط معرف الموظف بالدالة ام نربط معه رقم الفترة ايضا

 

هذا سيعتمد على ما إذا كان لكل موظف فترة واحدة فقط يومياً ( ومن سياق الحديث السابق لا اعتقد ذلك !! ) ، فيكفي ربط الدالة بمعرف الموظف فقط .
أما إذا كان يمكن أن يسجل الموظف توقيعاً في أكثر من فترة (صباحي + مسائي) ، فهنا من الأفضل أن تأخذ الدالة أيضاً FtraID ( رقم الفترة ) لضمان دقة التحليل .

والدالة الجميلة ، لي تعقيب واحد عليها . في السطر :-
 

If minutes > 59 Then hours = hours + 1: minutes = 0

أرى أنه غير ضروري !! لأنه من المستحيل أن تكون minutes  أكبر من 59 بسبب عملية Mod 60  السابقة !!!!

أما فيما يخص الدالة ، فقط لأني سأخرج من العمل بعد قليل ، وسأحاول البدء بمشاركة بسيطة بأقرب فرصة  .

10 دقائق مضت, ابوخليل said:

جرب الموظف سالم .. فترته خاص من التاسعة الى الحادية عشر ونصف صباحا  لاحظت :

الساعة عندي الآن  4:20 مساء

1- سمح له بالتوقيع

1- الرسالة تبين انه في الصباح رغم ان التوقيع الآن

قد يكون تنسيق الوقت !!!

لكن انظر الوقت والتنفيذ الآن ..

12 دقائق مضت, ابوخليل said:

دعنا الآن من الأكواد وضبطها لتحقيق الشروط  

 

دعنا منها الآن .👍.

12 دقائق مضت, ابوخليل said:

اكتشفت الآن ان حقول الوقت المتاح قبل وبعد التوقيع يجب ان تكون ضمن جدول الفترات وفائدة ذلك  :

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

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

وعلى سبيل المثال بهذا الشكل رح نعتمد على start_signin و end_signout بدل ما نعتمد على VBA   ( start_signin و end_signout = حقلين افتراضيات يعبران عن بداية ونهاية التوقيع )

معلمي الفاضل  ..

بناءً على ما أسلفتم ، ومن خلال الجدول الجديد الخاص بالتحكم :-

• تم تعديل اسلوب مطابقة الفترة لتراعي السماح قبل و بعد .
• التحقق من آخر توقيع للموظف بحيث إذا مضى عليه أقل من waitBtween دقيقة ، فيتم رفض التوقيع الجديد .

وبناءً عليه ، يكون تعديلي بهذا الشكل :-

Private Sub ID_AfterUpdate()
    On Error GoTo Err_Handler

    Dim db As DAO.Database
    Dim rsEmp As DAO.Recordset
    Dim rsShift As DAO.Recordset
    Dim rsCtrl As DAO.Recordset
    Dim rsLastMove As DAO.Recordset
    Dim UserId As String
    Dim empName As String
    Dim currentTime As Date
    Dim shiftId As Variant
    Dim checkType As String
    Dim sql As String
    Dim periodName As String
    Dim startWork As Date, endWork As Date
    Dim allowedBefore As Long, allowedAfter As Long, waitBetween As Long
    Dim lastTime As Date

    UserId = Trim(Me.id)
    If UserId = "" Then
        MsgBox "يرجى إدخال رقم الموظف", vbExclamation + vbMsgBoxRight, ""
        Exit Sub
    End If

    currentTime = Time()
    Set db = CurrentDb

    sql = "SELECT * FROM tblNames WHERE UserId = '" & UserId & "'"
    Set rsEmp = db.OpenRecordset(sql)
    If rsEmp.EOF Then
        MsgBox "رقم الموظف غير موجود في جدول الموظفين", vbExclamation + vbMsgBoxRight, ""
        rsEmp.Close
        Exit Sub
    End If
    empName = Nz(rsEmp!s_name, "الموظف")
    rsEmp.Close

    Set rsCtrl = db.OpenRecordset("SELECT TOP 1 * FROM tbl_Ctrl")
    If rsCtrl.EOF Then
        MsgBox "يرجى التحقق وضبط اعدادات التحكم", vbCritical + vbMsgBoxRight, ""
        Exit Sub
    End If
    waitBetween = Nz(rsCtrl!waitBtween, 1)
    allowedBefore = Nz(rsCtrl!timeBefore, 0)
    allowedAfter = Nz(rsCtrl!timeAfter, 0)
    rsCtrl.Close

    shiftId = "0"
    periodName = "غير محددة"
    Set rsShift = db.OpenRecordset("SELECT * FROM tbl_Ftrat")
    Do While Not rsShift.EOF
        startWork = DateAdd("n", -allowedBefore, rsShift!start_work)
        endWork = DateAdd("n", allowedAfter, rsShift!end_work)
        If currentTime >= TimeValue(startWork) And currentTime <= TimeValue(endWork) Then
            shiftId = CStr(rsShift!id)
            periodName = rsShift!ftraName
            Exit Do
        End If
        rsShift.MoveNext
    Loop
    rsShift.Close

'------------------------- ( في حال أردنا التخصيص )
''        If shiftId = "0" Then
''            MsgBox "لا توجد فترة مناسبة للوقت الحالي ، لا يمكن تسجيل التوقيع", vbExclamation + vbMsgBoxRight, ""
''            Exit Sub
''        End If
'-------------------------

    sql = "SELECT TOP 1 chekInOut FROM tblcomIn WHERE UserId = '" & UserId & "' ORDER BY chekInOut DESC"
    Set rsLastMove = db.OpenRecordset(sql)
    If Not rsLastMove.EOF Then
        lastTime = rsLastMove!chekInOut
        If DateDiff("s", lastTime, Now) < (waitBetween * 60) Then
            MsgBox "لا يمكنك التوقيع مرتين خلال أقل من " & waitBetween & " دقيقة", vbExclamation + vbMsgBoxRight, ""
            rsLastMove.Close
            Exit Sub
        End If
    End If
    rsLastMove.Close

    sql = "SELECT TOP 1 chekType FROM tblcomIn WHERE UserId = '" & UserId & "' AND DateValue(chekInOut) = Date() AND FtraID = '" & shiftId & "' ORDER BY chekInOut DESC"
    Set rsLastMove = db.OpenRecordset(sql)
    If Not rsLastMove.EOF Then
        If rsLastMove!chekType = "1" Then
            checkType = "2"
        Else
            checkType = "1"
        End If
    Else
        checkType = "1"
    End If
    rsLastMove.Close

    sql = "INSERT INTO tblcomIn (UserId, chekInOut, chekType, FtraID) VALUES " & _
          "('" & UserId & "', #" & Format(Now, "yyyy-mm-dd hh:nn:ss") & "#, '" & checkType & "', '" & shiftId & "')"
    db.Execute sql, dbFailOnError

    MsgBox "تم تسجيل " & IIf(checkType = "1", "الدخول", "الخروج") & vbCrLf & _
           "الموظف: " & empName & vbCrLf & "الفترة: " & periodName, vbInformation + vbMsgBoxRight, ""

    Me.id = ""
    Me.id.SetFocus
    Exit Sub

Err_Handler:
    MsgBox " : خطأ أثناء تنفيذ العملية" & vbCrLf & Err.Description, vbCritical + vbMsgBoxRight, ""
End Sub

ملاحظة ..

في الجزء :-

shiftId = "0"
periodName = "غير محددة"

استخدمته لتهيئة متغيرين رئيسيين قبل الدخول في حلقة البحث عن الفترة الحالية المناسبة ( tbl_Ftrat ) .

حيث أن القيمة ( 0 ) هنا تعني مبدئياً : ( لا توجد فترة مناسبة تم تحديدها بعد ) .

وطبعاً سيتم تعيين قيمة فعلية له لاحقاً من الجدول tbl_Ftrat عندما يطابق الوقت الحالي فترة ما داخل الجدول . من خلال الجملة :-

If currentTime >= TimeValue(startWork) And currentTime <= TimeValue(endWork) Then
    shiftId = CStr(rsShift!id)

بحيث إذا وجد وقت يطابق الفترة ، يتم تعيين رقم الفترة الحقيقي . وكذلك الأمر فيما يتعلق بـ "غير محددة" ....

والهدف كان في فكري ، للتحكم في الحالات غير المتوقعة :-

• فإذا لم يعثر على فترة مناسبة ضمن الوقت والسماح ، تبقى القيم الافتراضية ( 0 و غير محددة ) .
• ولتسجيل التوقيع حتى في حال عدم المطابقة . في بعض الحالات ، قد ترغب بتسجيل التوقيع رغم عدم انطباقه على أي فترة . ( من باب الإحتياط )

وطبعاً قابل لتخصيصه كجزء شرطي . فمثلاً إذا أردت منع التوقيع تماماً في حالة عدم مطابقة أي فترة ، يمكن وضع شرط كالآتي في نهاية حلقة البحث :-

    Loop
    rsShift.Close
      If shiftId = "0" Then
          MsgBox "لا توجد فترة مناسبة للوقت الحالي ، لا يمكن تسجيل التوقيع", vbExclamation + vbMsgBoxRight, ""
          Exit Sub
      End If

وطبعاً سيتم إلغاء التسجيل وعدم تنفيذ باقي الكود !!!

وطبعاً وجب التذكير بأنني أخذت على عاتقي تعديل منطق احتساب وقت الانتظار بين التوقيعين ليكون مقروناً ومشروطاً بالموظف الحالي فقط . يعني لو أردنا الانتظار دقيقة لتسجيل الحضور لـ 20 موظف على سبيل المثال !! فهذا يعني أن آخر موظف سيكون متأخراً 20 دقيقة هههههههه حسب الوقت الذي سيتم تسجيله له ( صحيح ) ، ولذا ألزمت التحقق من فترة الانتظار برقم الموظف .

فكرتي المتواضعة ..

comOutDb2.zip