عبدالله كاظم

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

شوف التعديل على الملف

ان شاء الله يكون هو المطاوب

Count_mess.mdb

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

جرب غير هذا السطر :

With Application.FileDialog(4)

بالتالي:

With Application.FileDialog(1)

أستاذ @حمدى الظابط

في نقطتين:

1- لما بكبس على توزيع آلي بهنق معاي الأكسس (الظاهر أن الاكسس بدخل لوب وما بيطلع منها)، في المرفق اللي أنت أرسلته وكما اللي أرسله الأستاذ خالد عبدالغفار.

2- المعذرة قاعد أحاول أفهم فكرة توزيع الجدول اللي أنت ما أستاذ @خالد عبد الغفار تشتغلوا عليها وماني قادر أفهمها فيا ريت يكون توضيح حق فكرة عمل المشروع وآلية التوزيع وبعدها إذا أقدر أساعد بالخدمة.

مع فائق التحية

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

الأخ @خالد عبد الغفار شوف التعديل في المرفق التالي ان شاء الله يكون هو المطلوب.

بخصوص شرح الكود تفضل

Private Function getAllPer() As Long 'يقوم بحساب مجموع الحصص الاسبوعية في الجدول بناء على البيانات في جدول [tblDays]
    Dim str As String
    Dim rst As Recordset
    
    str = "SELECT * FROM tblDays"
    
    Set rst = CurrentDb.OpenRecordset(str)
    
    If Not (rst.EOF) Then
        getAllPer = 0
        rst.MoveFirst
        
        Do Until rst.EOF = True
            getAllPer = getAllPer + rst!NoOfClasses
            rst.MoveNext
        Loop
    End If
End Function

Private Function getAllTCCount() As Long 'يقوم بحساب مجموع انصبة جميع المعلمين من الحصص من جدول [tblTeachers]
    Dim str As String
    Dim rst As Recordset
    
    str = "SELECT * FROM tblTeachers"
    
    Set rst = CurrentDb.OpenRecordset(str)
    
    If Not (rst.EOF) Then
        getAllTCCount = 0
        rst.MoveFirst
        
        Do Until rst.EOF = True
            getAllTCCount = getAllTCCount + rst!classCount
            rst.MoveNext
        Loop
    End If
End Function

'هذا الفانكشن حق عمل رقم عشوائي بين رقمين ومو أنا الكاتبه
Private Function GetRndNo(ByVal lLowerVal As Long, ByVal lUpperVal As Long, Optional bInclVals As Boolean = True) As Long
    On Error GoTo Error_Handler
    
    Dim lTmp As Long
 
    'Swap the lLowerVal and lUpperVal values, if they were inversed in the originating
    '   function call
    If lLowerVal > lUpperVal Then
        lTmp = lLowerVal
        lLowerVal = lUpperVal
        lUpperVal = lTmp
    End If
 
    'Adjust the boundary values should the user specify to exclude them from the
    '   possible returned values
    If bInclVals = False Then
        lLowerVal = lLowerVal + 1
        lUpperVal = lUpperVal - 1
    End If
 
    'Calculate our random number!
    Randomize
    GetRndNo = Int((lUpperVal - lLowerVal + 1) * Rnd + lLowerVal)
 
Error_Handler_Exit:
    On Error Resume Next
    Exit Function
 
Error_Handler:
    'LogError Err.Number, Err.Description, sModName & "\GetRndNo", , True, Erl
    MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
           "Error Number: " & Err.Number & vbCrLf & _
           "Error Source: GetRndNo" & vbCrLf & _
           "Error Description: " & Err.Description & _
           Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
           , vbOKOnly + vbCritical, "An Error has Occured!"
           
    Resume Error_Handler_Exit
End Function

Private Sub test05() 'هنا يتم توزيع الجدول باستخدام جميع ما في الأعلى

    'تعريف المتغيرات المستخدمه في الكود
    Dim strTeacher As String, strDay As String, strTimeTable
    Dim rstTeacher As Recordset, rstDay As Recordset, rstTimeTable As Recordset
    Dim randOFDays As Long
    Dim randOFDaysX As Long
    Dim TCount As Long
    
    Dim TCCount As Integer
    Dim dayC As Integer
    Dim xCls As String
    Dim toExit1 As Long
    
    
    'هنا اختبار إذا تم ادخال بيانات أيام الاسبوع. إذا لا توجد سجلات يخرج من العملية
    If DCount("dayID", "tblDays") = 0 Then Exit Sub
    
    'عمل استعلام للجدول [tblTeachers]
    strTeacher = "SELECT * FROM tblTeachers"
    Set rstTeacher = CurrentDb.OpenRecordset(strTeacher)
    
    'الذهاب إلى السجل الأول في جدول المعلمين
    rstTeacher.MoveFirst
    
    TCount = 0 'اعطاء قيمة صفر للمتغير اللي يختبر عدد المعلمين بحيث يزيد مع كل دورة وهو عداد للمعلمين
    
    'البدء في الدخول لوب للمعلمين، بمعني يدخل المعلم الأول ويوزع جدوله وبعدها ينتقل للمعلم الثاني... وهكذا
    'بالامكان عمل لوب على المعلمين بطريقة ثانية
    Do
        TCCount = 0 'اعطاء قيمة صفر للمتغير اللي استخدمه لاختبار عدد حصص المعلم الحالي وهو عداد حصص المعلم
line00:
        toExit = 0 'هذا المتغير استخدمه للأمان يمكن يكون في خطأ في البيانات المدخله ويدخل اللوب ولا يقدر يطلع منه. فهذا طوق نجاة:)
        dayC = 0 ' متغير لاختبار الأيام في اللوب التالي وهو عداد الأيام
        While dayC < DCount("dayID", "tblDays") 'بداية لوب الأيام بحث يعطي المعلم حصة في اليوم العشوائي الأول وبعدها حصة في ثاني إلى أن يكمل عدد الأيام
line01:
            If TCCount = rstTeacher!classCount Then GoTo line02 ' هنا اختبار إذا قيمة المتغير تساوت مع عدد نصاب المعلم الحالي يروح إلى [line02]
            
            randOFDays = GetRndNo(1, DCount("dayID", "tblDays")) 'اختيار يوم عشوائي
            If randOFDays = randOFDaysX Then GoTo line01 'اختبار إذا كان اليوم العشوائي الأول يتساوي مع اليوم العشوائي الذي سيليه ينتقل [line01]
            randOFDaysX = randOFDays 'اسناد قيمة اليوم العشوائي إلى متغير يستخدم في الاختبار السابق
            
            'هنا بداية تعبئة الجدول
            strDay = "SELECT * FROM tblDays" 'عمل استعلام لجدول الأيام
            
            Set rstDay = CurrentDb.OpenRecordset(strDay)
            rstDay.Move randOFDays - 1
            
            'هنا يتم اختيار حصة عشوائية
            xCls = "cls" & GetRndNo(1, rstDay!NoOfClasses)
            
            'هنا الاستعلام لجدول [TimeTable] بناء على اليوم المختار في السابق
            strTimeTable = "SELECT TimeTable.* FROM TimeTable WHERE (((TimeTable.theDay)=" & randOFDays & "));"
            Set rstTimeTable = CurrentDb.OpenRecordset(strTimeTable)
            
            'اختبار أن الحصة المختارة عشوائياً في هذا اليوم لم يسجل فيها شيء
            If IsNull(rstTimeTable.Fields(xCls)) Then
                'فإذا كانت فاضية يتم تحديثها ويدخل فيها اختصار المعلم
                CurrentDb.Execute "UPDATE TimeTable SET " & xCls & "= '" & rstTeacher!Shortcut & "' WHERE ((([theDay])=" & randOFDays & "));"
                
                TCCount = TCCount + 1 'زيادة واحد على عدد حصص المعلم
            Else
                toExit = toExit + 1
                If toExit = 10000 Then Exit Sub
                
                'إذا كانت الحصة غير فاضية يتم الرجوع إلى [line01] لإختيار حصة أخرى
                GoTo line01
            End If
            
            dayC = dayC + 1 'هنا يتم زيادة واحد على قيمة عداد الأيام
            If TCCount < rstTeacher!classCount And dayC = DCount("dayID", "tblDays") Then GoTo line00
        Wend
line02:
        TCount = TCount + 1 'هنا يتم زيادة واحد على قيمة عداد المعلمين
        rstTeacher.MoveNext 'الانتقال للمعلم التالي
    Loop While TCount < DCount("teacherID", "tblTeachers") 'العودة للوب حتى ينتهي من جميع المعلمين
    
End Sub

Private Sub Command0_Click()
    CurrentDb.Execute "DELETE * FROM TimeTable" 'يقوم بحذف البيانات في جدول [tiemYable]
    CurrentDb.Execute "INSERT INTO TimeTable ( theDay ) SELECT dayID FROM tblDays;" 'يقوم باضافة أرقام الأيام في جدول [TimeTable]
    Me.subfrmTimeTable.Requery 'يقوم بعمل اعادة استعلام النموذج الفرعي [subfrmTimeTable]
    
    getAllPer 'استدعاء فانكشن حساب عدد الحصص الاسبوعية
    getAllTCCount 'استدعاء مجموع انصبة المعلمين
    
    If getAllTCCount > getAllPer Then 'اختبار إذا كان مجموع انصبة المعلمين أكبر من عدد الحصص الاسبوعية فيخرج من العملية
        MsgBox "عدد الحصص الأسبوعية أقل من مجموع أنصبة المعلمين!"
        Exit Sub
    Else
        test05 'استدعاء sub لعمل توزيع الجدول
    End If
End Sub

والمعذرة إذا كان الشرح غير جيد

Database2_1.zip

العفو أستاذ @حمدى الظابط

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

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

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

مع فائق الاحترام والتقدير لك

TimeTable1.accdb

و عليكم السلام ورحمة الله وبركاته أخوي @حمدى الظابط

حاولت أفهم طبيعة المشروع حقك بس ما قدرت .. الظاهر التركيز حقي منخفض شوي 😅

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

هو بس تجربة للتوزيع العشوائي ممكن تستفيد منه

TimeTable.accdb

ما يحتاج تحفظ المتبقي على العميل. اللي تحتاجه تعمل جمع للي دفعه العميل وتنقصه من القيمة الاجمالية. هذا والله أعلم

شوف الملف التالي

Customers.accdb

يعطيك العافية أخوي @kanory جهزت الملف

أخوي @ابا جودى عافاك الله وكذلك أحبك في الله

العفو أخوي

بخصوص الموديول تفضل @ابا جودى

هذي الفانكشن نحطها في كلاس

Public Function getBackColor(DayName As String, repName As String)
On Error Resume Next
    Dim rep As Report
    Dim chst As String
    
    Set rep = Reports(repName)
    Select Case DayName
        Case "السبت", "Saturday", "Sat"
            chst = Nz(DLookup("[Sa]", "tblDayColoer", acFirst), "16777215")
            rep.Detail.BackColor = chst
            
        Case "الاحد", "Sunday", "Sun "
            chst = Nz(DLookup("[Su]", "tblDayColoer", acFirst), "16777215")
            rep.Detail.BackColor = chst
        
        Case "الاثنين", "Monday", "Mon"
            chst = Nz(DLookup("[Mo]", "tblDayColoer", acFirst), "16777215")
            rep.Detail.BackColor = chst

        Case "الثلاثاء", "Tuesday", "Tue"
            chst = Nz(DLookup("[Tu]", "tblDayColoer", acFirst), "16777215")
            rep.Detail.BackColor = chst
            
        Case "الاربعاء", "Wednesday", "Wed"
            chst = Nz(DLookup("[We]", "tblDayColoer", acFirst), "16777215")
            rep.Detail.BackColor = chst

        Case "الخميس", "Thursday", "Thu"
            chst = Nz(DLookup("[Th]", "tblDayColoer", acFirst), "16777215")
            rep.Detail.BackColor = chst
        
        Case "الجمعه", "Friday", "Fri"
            chst = Nz(DLookup("[Fr]", "tblDayColoer", acFirst), "16777215")
            rep.Detail.BackColor = chst
            
    End Select
End Function

وهذا الكود نستخدمها في مع حدث On Format في التقرير

Call getBackColor(Me.DayName, Me.Name)

غير خاصية Alternate Back Color إلى No Color

رائع أخوي @ابا جودى المرفق يعمل بشكل بدون مشاكل

إما إذا كان قصدك في مرفق الأخ السائل فالـ Name حق Detail في في ملفه هو [تفاصيل] تقريبا

وعليكم السلام

بعد اذن الأخ @kanory

جرب الكود التالي في حدث On Load أو عند التحميل للتقرير

    Select Case Format(Date, "dddd")
        Case "Sunday"
            Me.مربع_خانة48.BackColor = RGB(156, 216, 255)

        Case "Monday"
            Me.مربع_خانة48.BackColor = RGB(214, 204, 172)

        Case "Tuesday"
            Me.مربع_خانة48.BackColor = RGB(214, 172, 213)

        Case "Wednesday"
            Me.مربع_خانة48.BackColor = RGB(172, 214, 173)

        Case "Thursday"
            Me.مربع_خانة48.BackColor = RGB(214, 175, 172)

        Case "Friday"
            Me.مربع_خانة48.BackColor = RGB(174, 172, 214)

        Case "Saturday"
            Me.مربع_خانة48.BackColor = RGB(244, 122, 237)

    End Select

وعليكم السلام

تفضل

booking.zip

الحمدلله

والعفو اخوي

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

شوف هذا الموضوع

في ٢٥‏/٢‏/٢٠١٠ at 18:03, ابوخليل said:

السلام عليكم

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

اخي حاتم :

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

1- في حدث عند التحميل للنموذج الصق هذا الكود ReSizeForm Me

2- غير مقاسات الشاشة في الوحدة النمطية في هذين السطرين

Private Const DESIGN_HORZRES As Long = 1024

Private Const DESIGN_VERTRES As Long = 768

db1.rar

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

اتفضل جرب هذا الكود في زر أمر

    Dim i As Long, i2 As Long
    Dim x As String, x2 As String
    Dim ftNo As String
    
    x = Replace(Me.N1, "L", "")
    x2 = Replace(Me.N2, "L", "")
    
    i = CLng(x)
    i2 = CLng(x2)
    
    Do Until i = i2 + 1
        Debug.Print i
        ftNo = "L" & Format(i, "00000")
        If DCount("[Rjmfatwra]", "AfwtIar_arwd", "[Rjmfatwra]='" & ftNo & "'") <> 0 Then
            CurrentDb.Execute "DELETE * FROM AfwtIar_arwd WHERE ((([Rjmfatwra])='" & ftNo & "'));"
        End If
        i = i + 1
    Loop
    
    Me.N1 = Null
    Me.N2 = Null

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

جرب الكود التالي في زر أمر:

Call Shell("C:\npp\notepad++.exe")

العفو أخوي خالد

بخصوص طلبك الخاص بالمراسلات (الصادر والوارد) يا ريت يكون يكون في موضوع مستقل،

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

وإذا ما حصلت حاجة الجميع ما رايح يقصر معاك

وموفق اخوي

جرب نموذج البحث فيه ازرار للطباعة

وتقدر تعمل البقية بنفس الطريقة

قسم الامن - 5.zip

الحمد لله

تفضل أخوي

جدول الحصص_20 (2).zip

العفو أستاذ @حمدى الظابط

بس اللي فهمته من استفسارك كما في الصورة المرفقة

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

6 ساعات مضت, ابا جودى said:

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

كل عام وانتم الي الله اقرب

وكل عام وأنت إلى الله أقرب

العفو أستاذي @ابا جودى

3 ساعات مضت, حمدى الظابط said:

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

العفو أخي

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

والمعذرة عن أي تقصير