اذهب الي المحتوي
أوفيسنا

Foksh

أوفيسنا
 عرض الملف الشخصي  عرض المشاركات

  • Posts

    4409

  • تاريخ الانضمام

  • تاريخ اخر زياره

  • Days Won

    186

 نوع المحتوي 

مشاركات المكتوبه بواسطه Foksh

    تصدير الى اكسيل مع الاجماليات

    في قسم الأكسيس Access

    قام بنشر

    وعليكم السلام أخي يوسف ..

    تفضل ملفك بعد التعديل ، حيث تم استخدام الحدث التالي في الزر :- 

    Private Sub أمر0_Click()
    On Error GoTo ErrorHandler
    
    Dim db As DAO.Database
    Dim qdf As DAO.QueryDef
    Dim strSQL As String
    Dim strFileName As String
    Dim strFilePath As String
    Dim strQueryName As String
    
    strSQL = "SELECT Tcode, Tname, Out_Lab, IN_Lab, Total, IN_Staff, Total_Staff FROM (" & _
             "  SELECT 0 AS SortID, Tcode, Tname, Out_Lab, IN_Lab, Total, IN_Staff, Total_Staff FROM Tbl_Tests " & _
             "  UNION ALL " & _
             "  SELECT 1 AS SortID, '', 'المجموع الكلي', SUM(Out_Lab), SUM(IN_Lab), SUM(Total), SUM(IN_Staff), SUM(Total_Staff) FROM Tbl_Tests" & _
             ") " & _
             "ORDER BY SortID, Val(Tcode), Tcode;"
    
    strFileName = Format(Now, "yyyy-mm-dd_hh-nn-ss") & ".xlsx"
    strFilePath = CurrentProject.Path & "\" & strFileName
    
    strQueryName = "TempExportQuery"
    Set db = CurrentDb
    
    On Error Resume Next
    db.QueryDefs.Delete strQueryName
    On Error GoTo ErrorHandler
    
    Set qdf = db.CreateQueryDef(strQueryName, strSQL)
    
    DoCmd.OutputTo acOutputQuery, strQueryName, acFormatXLSX, strFilePath, False
    
    db.QueryDefs.Delete strQueryName
    
    MsgBox "تم تصدير البيانات بنجاح", vbInformation + vbMsgBoxRight, "تم التصدير"
    
ExitProcedure:
    Set qdf = Nothing
    Set db = Nothing
    Exit Sub

ErrorHandler:
    MsgBox "حدث خطأ أثناء عملية التصدير", vbCritical + vbMsgBoxRight, "خطأ"
    Resume ExitProcedure
End Sub

     

    وسيتم انشاء ملف اكسل باسم = الوقت الحالي وتاريخ اليوم ، وتستطيع تغيير اسم الملف كما تريد .

    JO.zip

    تجزئة الجدول إلى استعلامات

    في قسم الأكسيس Access

    قام بنشر

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

    جرب هذا الاستعلام 😉 :- 

    SELECT S.StudentID, S1.on1 AS S1_on1, S1.on2 AS S1_on2, S1.on3 AS S1_on3, S1.on4 AS S1_on4, S1.on5 AS S1_on5, S1.on6 AS S1_on6, S1.on7 AS S1_on7, S1.on8 AS S1_on8, S1.on9 AS S1_on9, S1.to1 AS S1_to1, S1.to2 AS S1_to2, S1.to3 AS S1_to3, S1.to4 AS S1_to4, S1.to5 AS S1_to5, S1.to6 AS S1_to6, S1.to7 AS S1_to7, S1.to8 AS S1_to8, S1.to9 AS S1_to9, S1.tr1 AS S1_tr1, S1.tr2 AS S1_tr2, S1.tr3 AS S1_tr3, S1.tr4 AS S1_tr4, S1.tr5 AS S1_tr5, S1.tr6 AS S1_tr6, S1.tr7 AS S1_tr7, S1.tr8 AS S1_tr8, S1.tr9 AS S1_tr9, S2.on1 AS S2_on1, S2.on2 AS S2_on2, S2.on3 AS S2_on3, S2.on4 AS S2_on4, S2.on5 AS S2_on5, S2.on6 AS S2_on6, S2.on7 AS S2_on7, S2.on8 AS S2_on8, S2.on9 AS S2_on9, S2.to1 AS S2_to1, S2.to2 AS S2_to2, S2.to3 AS S2_to3, S2.to4 AS S2_to4, S2.to5 AS S2_to5, S2.to6 AS S2_to6, S2.to7 AS S2_to7, S2.to8 AS S2_to8, S2.to9 AS S2_to9, S2.tr1 AS S2_tr1, S2.tr2 AS S2_tr2, S2.tr3 AS S2_tr3, S2.tr4 AS S2_tr4, S2.tr5 AS S2_tr5, S2.tr6 AS S2_tr6, S2.tr7 AS S2_tr7, S2.tr8 AS S2_tr8, S2.tr9 AS S2_tr9, S3.on1 AS S3_on1, S3.on2 AS S3_on2, S3.on3 AS S3_on3, S3.on4 AS S3_on4, S3.on5 AS S3_on5, S3.on6 AS S3_on6, S3.on7 AS S3_on7, S3.on8 AS S3_on8, S3.on9 AS S3_on9, S3.to1 AS S3_to1, S3.to2 AS S3_to2, S3.to3 AS S3_to3, S3.to4 AS S3_to4, S3.to5 AS S3_to5, S3.to6 AS S3_to6, S3.to7 AS S3_to7, S3.to8 AS S3_to8, S3.to9 AS S3_to9, S3.tr1 AS S3_tr1, S3.tr2 AS S3_tr2, S3.tr3 AS S3_tr3, S3.tr4 AS S3_tr4, S3.tr5 AS S3_tr5, S3.tr6 AS S3_tr6, S3.tr7 AS S3_tr7, S3.tr8 AS S3_tr8, S3.tr9 AS S3_tr9, S3.TotalSum, S3.average, S3.Grade, S3.FailCount, S3.Result
FROM ((TBL_Students AS S LEFT JOIN TBL_Final1 AS S1 ON S.StudentID = S1.StudentID AND S1.SemesterID = 1) LEFT JOIN TBL_Final1 AS S2 ON S.StudentID = S2.StudentID AND S2.SemesterID = 2) LEFT JOIN TBL_Final1 AS S3 ON S.StudentID = S3.StudentID AND S3.SemesterID = 3;

    تم استخدام LEFT JOIN بدلاً من INNER JOIN لضمان ظهور الطالب في التقرير حتى لو نقصت بيانات أحد الفصول الدراسية (في هذه الحالة ستظهر درجات ذلك الفصل فارغة بدلاً من اختفاء الطالب تماماً من التقرير) .

     

    واخبرنا بالنتيجة :smile:

    مساعدة في تصفية تقرير

    في قسم الأكسيس Access

    قام بنشر

    منذ ساعه, basem1978 said:

    اولا شكرا جزيلا على سرعة الرد

    كما أشار بالتعديل الأستاذ خليفة ، استبدل الاستعلام التالي بالاستعلام الذي هو مصدر التقرير :- 

    SELECT 
    [استعلام اساسي التكليف].[رقم الموظف],
    [استعلام اساسي التكليف].[اسم الموظف],
    [استعلام اساسي التكليف].[رقم القسم],
    [استعلام اساسي التكليف].[اسم القسم],
    [استعلام اساسي التكليف].[رقم الموظف - التكليف],
    [استعلام اساسي التكليف].[تاريخ تسجيل التكليف],
    [استعلام اساسي التكليف].[مدة التكليف],
    [استعلام اساسي التكليف].[تاريخ التكليف],
    [استعلام اساسي التكليف].[ملاحظات التكليف],
    [استعلام اساسي التكليف].[رقم نوع التكيف],
    [استعلام اساسي التكليف].[التكليف - رقم نوع التكليف],
    [استعلام اساسي التكليف].[نوع التكليف],
    [استعلام اساسي التكليف].[المسمى الوظيفي],
    [استعلام اساسي التكليف].[اسم يوم التكليف],
    [استعلام اساسي التكليف].[اسم شهر التكليف],
    [استعلام اساسي التكليف].[الى تاريخ],
    [استعلام اساسي التكليف].[رقم صلاحية التشغيل],
    [استعلام اساسي التكليف].[نوع صلاحية التشغيل],
    [استعلام اساسي التكليف].[رقم شهر التكليف],
    [استعلام اساسي التكليف].[المسئول المباشر],
    [استعلام اساسي التكليف].[اسم المسئول],
    [استعلام اساسي التكليف].[سنة التكليف]
FROM [استعلام اساسي التكليف]
WHERE [استعلام اساسي التكليف].[رقم شهر التكليف] = [ادخل رقم شهر التكليف]
  AND [استعلام اساسي التكليف].[رقم الموظف] IN (
        SELECT [رقم الموظف]
        FROM [استعلام اساسي التكليف]
        WHERE [رقم شهر التكليف] = [ادخل رقم شهر التكليف]
        GROUP BY [رقم الموظف]
        HAVING Count(*) > 10
  )
ORDER BY [استعلام اساسي التكليف].[تاريخ التكليف];

     

    مساعدة في تصفية تقرير

    في قسم الأكسيس Access

    قام بنشر

    27 دقائق مضت, basem1978 said:

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

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

    SELECT التكليف.[رقم الموظف - التكليف] AS رقم_الموظف, التكليف.[تاريخ التكليف]
FROM التكليف
WHERE (((التكليف.[رقم الموظف - التكليف]) In (SELECT التكليف.[رقم الموظف - التكليف]
    FROM التكليف
    WHERE Month([تاريخ التكليف]) = [ادخل رقم الشهر]
    GROUP BY التكليف.[رقم الموظف - التكليف]
    HAVING Count(*) > 10
)) AND ((Month([تاريخ التكليف]))=[ادخل رقم الشهر]))
ORDER BY التكليف.[رقم الموظف - التكليف];

     

    * ملاحظاتي ..

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

    محتاج معادلات لتجميع شيت باجمالي الشهور

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

    قام بنشر

    في 12‏/1‏/2026 at 11:54, ابراهيم170 said:

    شاكر ومقدر استاذ حجازي 

    هذا هو المطلوب بالضبط

    نرجو منكم إغلاق الموضوع باختياركم "إختر تمت الإجابة" لإجابة الأستاذ @hegazee بما أنها قد حققت مطلبك بنجاح.

     

    💐 وشكراً لمتابعتكم.

    تنسيق شهادة شكر .. تقرير

    في قسم الأكسيس Access

    قام بنشر

    في 9‏/1‏/2026 at 15:10, kanory said:

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

    أهلاً بك أخي الحبيب @kanory ، سيتم إن شاء الله إضافة العديد من الميزات الى الفكرة قريباً.

     

    21 دقائق مضت, jjafferr said:

    اخي فادي

    جميل عندما يستفيد الآخرين من عمل معين ، ويضاف عليه لمسات جميلة 🙂

    شكرا لك.

    معلمنا الحبيب واستاذي وأخي جعفر ..

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

     

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

    تغيير مسميات الأزرار

    في قسم الأكسيس Access

    قام بنشر

    بدايةً ما خطر ببالي كفكرة تتلخص في جدول واحد مخصص للتنفيذ ، ويحتوي الحقول التالية فرضاً ..

    • حقل لاسم النموذج = نصي
    • حقل لاسم الزر البرمجي = نصي
    • حقل للتسمية القديمة = نصي
    • حقل للتسمية الجديدة = نصي أيضاً
    • حقل للتنفيذ = نعم / لا

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

    يعني بشكل مبسط .زر في كل نموذج مخصص لفتح نموذج ضبط التسميات ( إن صح التعبير ) . وهذا النموذج سيعرض التسميات القديمة والجديدة لكل زر في النموذج الحالي . انظر الصورة كفكرة توضيحية بعد تطبيقها . حيث لدي نموذجين Form1 & Form2 ، بهما العديد من الأزرار للتطبيق والتغذية البصرية . ويوجد زر ايقونته = الإعدادات ، لاحظ انه عند النقر على هذا الزر ماذا حصل !!

    LblChanger01.thumb.gif.ac0728b4a1784ae5d0693febdcc8c9be.gif

    سيتم تحميل جميع تسميات الأزرار في النموذج الحالي بدلاً من الاسم البرمجي للزر . لأن المستخدم العادي لن يميز اسمه البرمجي . فكان التوجه إلى إظهار التسميات للأزرار هو الأنسب .

    الآن وبعد السيطرة على الأزرار وتحديدها ، انظر للتجربة التالية بعد تغيير اسم مجموعة أزرار ..

    LblChanger02.thumb.gif.42daa6f94a6ca9788feb6c4055bcc3a7.gif

    إذا كانت الفكرة مناسبة ، فسأقوم بطرح طريقة التطبيق في الرد التالي .. 

    اعتقد أن الموقع والمنتدى قيد التحديث والتطوير ..

    تغيير مسميات الأزرار

    في قسم الأكسيس Access

    قام بنشر

    منذ ساعه, ابوخليل said:

    اكتب في مربع النص ثم انقر مزدوجا على الزر

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

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

     

    هل توافقني الرأي ؟؟

    انشاء جدول بمواصفات خاصه

    في قسم الأكسيس Access

    قام بنشر

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

    Public Function GenerateSalary(yearInput As Integer)

    Dim db As DAO.Database
    Dim tDef As DAO.TableDef
    Dim fld As DAO.Field
    Dim rs As DAO.Recordset
    Dim startDate As Date, endDate As Date, d As Date
    Dim monthName As String
    Dim monthCode As Integer
    Dim shiftValue As Double
    Dim startDateTime As Date
    Dim endDateTime As Date
    Dim monthEndDate As Date
    Dim monthEndWorkDate As Date
    Dim m As Integer, y As Integer

    startDate = DateSerial(yearInput - 1, 12, 21)
    endDate = DateSerial(yearInput, 12, 20)

    On Error Resume Next
    DoCmd.DeleteObject acTable, "Salary"
    On Error GoTo 0

    Set db = CurrentDb
    db.Execute "CREATE TABLE Salary (" & _
           "ID AUTOINCREMENT PRIMARY KEY, " & _
           "WorkDate DATE, " & _
           "DayName TEXT(20), " & _
           "MonthName TEXT(20), " & _
           "monthCode LONG, " & _
           "shift CURRENCY, " & _
           "startDay DATE, " & _
           "endDay DATE)"

    Set tDef = db.TableDefs("Salary")

    Set fld = tDef.Fields("shift")
    On Error Resume Next
    fld.Properties("Format") = "#,##0.00"
    If Err.Number <> 0 Then
        Err.Clear
        fld.Properties.Append fld.CreateProperty("Format", dbText, "#,##0.00")
    End If
    fld.Properties("DecimalPlaces") = 2
    If Err.Number <> 0 Then
        Err.Clear
        fld.Properties.Append fld.CreateProperty("DecimalPlaces", dbInteger, 2)
    End If

    Set fld = tDef.Fields("startDay")
    On Error Resume Next
    fld.Properties("Format") = "hh:nn AM/PM"
    If Err.Number <> 0 Then
        Err.Clear
        fld.Properties.Append fld.CreateProperty("Format", dbText, "hh:nn AM/PM")
    End If

    Set fld = tDef.Fields("endDay")
    On Error Resume Next
    fld.Properties("Format") = "hh:nn AM/PM"
    If Err.Number <> 0 Then
        Err.Clear
        fld.Properties.Append fld.CreateProperty("Format", dbText, "hh:nn AM/PM")
    End If
    On Error GoTo 0

    Set fld = Nothing
    Set tDef = Nothing

    Set rs = db.OpenRecordset("Salary", dbOpenDynaset)

    monthCode = 0
    monthEndWorkDate = DateSerial(yearInput - 1, 12, 20)

    d = startDate
    Do While d <= endDate
        If Weekday(d, vbMonday) <> 5 And Weekday(d, vbMonday) <> 7 Then
            m = Month(d)
            y = Year(d)
            If Day(d) >= 21 Then
                m = m + 1
                If m = 13 Then
                    m = 1
                    y = y + 1
                End If
            End If
            monthName = Format(DateSerial(y, m, 1), "MMMM")

            monthCode = 0
            monthEndDate = DateSerial(Year(d), Month(d), 20)

            If Weekday(monthEndDate, vbMonday) = 5 Or Weekday(monthEndDate, vbMonday) = 7 Then
                monthEndWorkDate = monthEndDate
                Do
                    monthEndWorkDate = DateAdd("d", -1, monthEndWorkDate)
                Loop Until Weekday(monthEndWorkDate, vbMonday) <> 5 And Weekday(monthEndWorkDate, vbMonday) <> 7
            Else
                monthEndWorkDate = monthEndDate
            End If

            If d = monthEndWorkDate Then
                Select Case Month(d)
                    Case 12: If Year(d) = yearInput - 1 Then monthCode = 1 Else monthCode = 12
                    Case 1: monthCode = 1
                    Case 2: monthCode = 2
                    Case 3: monthCode = 3
                    Case 4: monthCode = 4
                    Case 5: monthCode = 5
                    Case 6: monthCode = 6
                    Case 7: monthCode = 7
                    Case 8: monthCode = 8
                    Case 9: monthCode = 9
                    Case 10: monthCode = 10
                    Case 11: monthCode = 11
                End Select
            End If

            If Weekday(d, vbMonday) = 6 Or Weekday(d, vbMonday) = 3 Then
                shiftValue = 1
                startDateTime = DateAdd("n", 30, DateSerial(Year(d), Month(d), Day(d)) + TimeSerial(8, 0, 0))
                endDateTime = DateSerial(Year(d), Month(d), Day(d)) + TimeSerial(13, 30, 0)
            Else
                shiftValue = 1.2
                startDateTime = DateAdd("n", 10, DateSerial(Year(d), Month(d), Day(d)) + TimeSerial(8, 0, 0))
                endDateTime = DateSerial(Year(d), Month(d), Day(d)) + TimeSerial(14, 30, 0)
            End If

            rs.AddNew
            rs!WorkDate = d
            rs!DayName = Format(d, "dddd")
            rs!monthName = monthName
            If monthCode > 0 Then
                rs!monthCode = monthCode
            Else
                rs!monthCode = Null
            End If
            rs!shift = shiftValue
            rs!startDay = startDateTime
            rs!endDay = endDateTime
            rs.Update
        End If
        d = d + 1
    Loop

    rs.Close
    Set rs = Nothing
    db.TableDefs.Refresh
    Set db = Nothing

    MsgBox "تم إنشاء الجدول بنجاح", vbInformation + vbMsgBoxRight, ""
    DoCmd.SelectObject acTable, "Salary", True

End Function

    طبعاً تم دمج الدالتين معاً . والإستغناء عن الإستدعاء المتكرر للجملة ElseIf باستخدام الدالة Select Case . وسيصبح الإستدعاء كمثال بالشكل التالي :- 

    Private Sub btnGenerate_Click()
    If IsNull(Me.TxtYear) Then
        MsgBox "أدخل رقم السنة", vbExclamation + vbMsgBoxRight, ""
        Me.TxtYear.SetFocus
        Exit Sub
    End If
    GenerateSalary (Me.TxtYear)
End Sub

     

     

    الملف بعد التعديل :-

    CalGen2.zip

    بعد التعديل الاخير الكود اصبح لايقطتع مبلغ الانخراط

    في قسم الأكسيس Access

    قام بنشر

    الموضوع الحالي تم فتح النقاش فيه داخل الموضوع التالي :-

     

     

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

     

    مغلق للتكرار في موضوع آخر غير منتهي .

    انشاء جدول بمواصفات خاصه

    في قسم الأكسيس Access

    قام بنشر · تم تعديل بواسطه Foksh
    تعديل الكود ليقوم بإضافة القيمة 1 ليومي السبت والأربعاء في الحقل Shift .

    في 23‏/12‏/2025 at 10:50, jo_2010 said:

    خالص الشكر للمجهود  المبذول ولكن لم اجد كود  2  لشهر فبراير وذلك لان نهاية الشهر 19/فبراير  لان يوم 20 يوم جمعة وهو غير مدرج بالجدول وكذلك الحال مع شهر ماس

    اريد الكود يكتب فى نهاية الشهر سواء  19 او 20

    اريد تنسيق الارقام قياسى والعلامة العشرية بعد رقمين بدل من مزدوج

    أخي الفاضل ، لم لا تقوم بطرح جميع المطلوب كاملاً بدلاً من النقاط المبعثرة 😅

    على العموم ، هذا التعديل لما طلبت ، تفضل ، استبدل الكود للزر بالتالي :- 

    Private Sub btnGenerate_Click()
    Dim db As DAO.Database
    Dim tDef As DAO.TableDef
    Dim fld As DAO.Field
    Dim rs As DAO.Recordset
    Dim startDate As Date, endDate As Date, d As Date
    Dim yearInput As Integer
    Dim monthName As String
    Dim monthCode As Integer
    Dim shiftValue As Double
    Dim startDateTime As Date
    Dim endDateTime As Date
    Dim monthEndDate As Date
    Dim monthEndWorkDate As Date
    
    If IsNull(TxtYear) Then
        MsgBox "أدخل رقم السنة", vbExclamation + vbMsgBoxRight, ""
        Me.TxtYear.SetFocus
    Exit Sub
    End If
    
    yearInput = Me.TxtYear
    startDate = DateSerial(yearInput - 1, 12, 21)
    endDate = DateSerial(yearInput, 12, 20)
    On Error Resume Next
    DoCmd.DeleteObject acTable, "Salary"
    On Error GoTo 0
    
    Set db = CurrentDb
    db.Execute "CREATE TABLE Salary (" & _
           "ID AUTOINCREMENT PRIMARY KEY, " & _
           "WorkDate DATE, " & _
           "DayName TEXT(20), " & _
           "MonthName TEXT(20), " & _
           "monthCode LONG, " & _
           "shift CURRENCY, " & _
           "startDay DATE, " & _
           "endDay DATE)"
    
    Set tDef = db.TableDefs("Salary")
    
    Set fld = tDef.Fields("shift")
    On Error Resume Next
    fld.Properties("Format") = "#,##0.00"
    If Err.Number <> 0 Then
        Err.Clear
        fld.Properties.Append fld.CreateProperty("Format", dbText, "#,##0.00")
    End If
    
    fld.Properties("DecimalPlaces") = 2
    If Err.Number <> 0 Then
        Err.Clear
        fld.Properties.Append fld.CreateProperty("DecimalPlaces", dbInteger, 2)
    End If
    
    Set fld = tDef.Fields("startDay")
    On Error Resume Next
    fld.Properties("Format") = "hh:nn AM/PM"
    If Err.Number <> 0 Then
        Err.Clear
        fld.Properties.Append fld.CreateProperty("Format", dbText, "hh:nn AM/PM")
    End If
    
    Set fld = tDef.Fields("endDay")
    On Error Resume Next
    fld.Properties("Format") = "hh:nn AM/PM"
    If Err.Number <> 0 Then
        Err.Clear
        fld.Properties.Append fld.CreateProperty("Format", dbText, "hh:nn AM/PM")
    End If
    
    On Error GoTo 0
    
    Set fld = Nothing
    Set tDef = Nothing
    
    Set rs = db.OpenRecordset("Salary", dbOpenDynaset)
    
    monthCode = 0
    monthEndWorkDate = DateSerial(yearInput - 1, 12, 20)
    
    d = startDate
    Do While d <= endDate
        If Weekday(d, vbMonday) <> 5 And Weekday(d, vbMonday) <> 7 Then
            monthName = CustomMonth(d)
            
            monthCode = 0
            
            monthEndDate = DateSerial(Year(d), Month(d), 20)
            
            If Weekday(monthEndDate, vbMonday) = 5 Or Weekday(monthEndDate, vbMonday) = 7 Then
                monthEndWorkDate = monthEndDate
                Do
                    monthEndWorkDate = DateAdd("d", -1, monthEndWorkDate)
                Loop Until Weekday(monthEndWorkDate, vbMonday) <> 5 And Weekday(monthEndWorkDate, vbMonday) <> 7
            Else
                monthEndWorkDate = monthEndDate
            End If
            
            If d = monthEndWorkDate Then
                If Month(d) = 12 And Year(d) = yearInput - 1 Then
                    monthCode = 1
                ElseIf Month(d) = 1 And Year(d) = yearInput Then
                    monthCode = 1
                ElseIf Month(d) = 2 Then
                    monthCode = 2
                ElseIf Month(d) = 3 Then
                    monthCode = 3
                ElseIf Month(d) = 4 Then
                    monthCode = 4
                ElseIf Month(d) = 5 Then
                    monthCode = 5
                ElseIf Month(d) = 6 Then
                    monthCode = 6
                ElseIf Month(d) = 7 Then
                    monthCode = 7
                ElseIf Month(d) = 8 Then
                    monthCode = 8
                ElseIf Month(d) = 9 Then
                    monthCode = 9
                ElseIf Month(d) = 10 Then
                    monthCode = 10
                ElseIf Month(d) = 11 Then
                    monthCode = 11
                ElseIf Month(d) = 12 Then
                    monthCode = 12
                End If
            End If
            
            If Weekday(d, vbMonday) = 6 Or Weekday(d, vbMonday) = 3 Then
                shiftValue = 1
                startDateTime = DateAdd("n", 30, DateSerial(Year(d), Month(d), Day(d)) + TimeSerial(8, 0, 0))
                endDateTime = DateSerial(Year(d), Month(d), Day(d)) + TimeSerial(13, 30, 0)
            Else
                shiftValue = 1.2
                startDateTime = DateAdd("n", 10, DateSerial(Year(d), Month(d), Day(d)) + TimeSerial(8, 0, 0))
                endDateTime = DateSerial(Year(d), Month(d), Day(d)) + TimeSerial(14, 30, 0)
            End If
            
            rs.AddNew
            rs!WorkDate = d
            rs!DayName = Format(d, "dddd")
            rs!monthName = monthName
            If monthCode > 0 Then
                rs!monthCode = monthCode
            Else
                rs!monthCode = Null
            End If
            rs!shift = shiftValue
            rs!startDay = startDateTime
            rs!endDay = endDateTime
            rs.Update
        End If
        d = d + 1
    Loop
    
    rs.Close
    Set rs = Nothing
    
    db.TableDefs.Refresh
    
    Set db = Nothing
    
    MsgBox "تم إنشاء الجدول بنجاح", vbInformation + vbMsgBoxRight, ""
    DoCmd.SelectObject acTable, "Salary", True
End Sub

     

    ملفك بعد التعديل :-

    CalGen.zip

     

×
×
  • اضف...

Important Information

  I accept