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

[منتصر الانسي]

مرفق لك مثالك بعد التعديل 

قمت بإضافة جدول tblDates والإستعلام qryDates

النتيجة النهائية ستجدها في الاستعلام Query1

أرجو أن يكون هو ماتبحث عنه

مع تحياتي

Database1.rar

[ابوخليل]

52 دقائق مضت, منتصر الانسي said:

أرجو أن يكون هو ماتبحث عنه

 

عجيب .. المبرمج المحترف لا يستعصي عليه شيء

الفكرة جميلة  ..  الف شكر استاذنا الكريم

[ابو جودي]

في 15‏/7‏/2025 at 22:13, منتصر الانسي said:

قمت بإضافة جدول tblDates والإستعلام qryDates

 ايه الحلاوة دى الله عليك بجد

في 15‏/7‏/2025 at 23:14, ابوخليل said:

عجيب .. المبرمج المحترف لا يستعصي عليه شيء

الفكرة جميلة  ..

فعلا الفكرة ولا اروع 

وعلشان عجبتنى الفكرة

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

الكود
 

Option Compare Database
Option Explicit

'' === ثوابت عامة لإعدادات توليد التواريخ ===
Public Const TABLE_NAME As String = "tblCalendarComponents"
Private Const QUERY_NAME As String = "qryGenerateFullDates"

Public Const DATE_TYPE_DAY As String = "DayType"
Public Const DATE_TYPE_MONTH As String = "MonthType"
Public Const DATE_TYPE_YEAR As String = "YearType"

Public Const DefaultYearOffset As Long = 3
Public Const DefaultStartYear As Long = 0
Public Const DefaultYearCount As Long = 100

Public Const MIN_YEAR As Long = 1900
Public Const MAX_YEAR As Long = 2100

'' ===  TestGenerateDates
Public Sub TestGenerateDates()
    ''--- سنة البدء (0 = القيمة الافتراضية)
    Dim lngStartYear As Long: lngStartYear = 0
    
    ''---  فرق السنوات الافتراضي
    Dim lngOffset As Long: lngOffset = DefaultYearOffset
    
    ''--- عدد السنوات المراد توليدها
    Dim lngYearCount As Long: lngYearCount = 10

    Call GenerateDates(lngStartYear, lngOffset, lngYearCount)
End Sub

'' ======= الإجراء الرئيسي لإنشاء الجدول والاستعلام =======
Public Sub GenerateDates( _
    Optional ByVal StartYear As Long = 0, _
    Optional ByVal YearOffset As Long = DefaultYearOffset, _
    Optional ByVal YearCount As Long = DefaultYearCount)

    On Error GoTo ErrorHandler

    ' تعيين الفرق الافتراضي إن لم يُمرر
    If YearOffset = -1 Then YearOffset = DefaultYearOffset

    ' حساب سنة البدء إذا لم تُمرر
    If StartYear = 0 Then StartYear = Year(Date) - YearOffset

    ' التحقق من سنة البدء ضمن النطاق
    If StartYear < MIN_YEAR Or StartYear > MAX_YEAR Then
        Err.Raise vbObjectError + 1000, , "StartYear يجب أن يكون بين " & MIN_YEAR & " و " & MAX_YEAR
    End If

    ' التحقق من عدد السنوات ضمن النطاق
    If YearCount < 1 Or YearCount > (MAX_YEAR - StartYear + 1) Then
        Err.Raise vbObjectError + 1001, , "YearCount يجب أن يكون بين 1 و " & (MAX_YEAR - StartYear + 1)
    End If

    ' إنشاء الجدول والاستعلام
    Call PopulateDateTable(StartYear, YearCount)
    Call CreateOrUpdateDateGenerationQuery

    MsgBox "تم إنشاء الجدول والاستعلام بنجاح.", vbInformation, "نجاح العملية"
    Exit Sub

ErrorHandler:
    MsgBox "حدث خطأ أثناء إنشاء الجدول أو الاستعلام:" & vbCrLf & _
           "رقم الخطأ: " & Err.Number & vbCrLf & _
           "الوصف: " & Err.Description, vbCritical, "خطأ"
End Sub

'' ======= ملء جدول التواريخ =======
Public Sub PopulateDateTable( _
    Optional ByVal StartYear As Long = DefaultStartYear, _
    Optional ByVal YearCount As Long = DefaultYearCount)

    On Error GoTo ErrorHandler

    Dim db As DAO.Database: Set db = CurrentDb

    ' حذف الجدول قبل الإنشاء
    On Error Resume Next
    db.TableDefs.Delete TABLE_NAME
    On Error GoTo ErrorHandler

    Call CreateDateTable(db)

    If StartYear = 0 Then StartYear = Year(Date) - DefaultYearOffset

    Dim i As Long
    For i = 1 To 31
        db.Execute "INSERT INTO " & TABLE_NAME & " (DateNo, DateType) VALUES (" & i & ", '" & DATE_TYPE_DAY & "')", dbFailOnError
    Next i

    For i = 1 To 12
        db.Execute "INSERT INTO " & TABLE_NAME & " (DateNo, DateType) VALUES (" & i & ", '" & DATE_TYPE_MONTH & "')", dbFailOnError
    Next i

    For i = 0 To YearCount - 1
        db.Execute "INSERT INTO " & TABLE_NAME & " (DateNo, DateType) VALUES (" & StartYear + i & ", '" & DATE_TYPE_YEAR & "')", dbFailOnError
    Next i

    Set db = Nothing
    Exit Sub

ErrorHandler:
    MsgBox "  خطأ أثناء تعبئة الجدول: " & Err.Description, vbCritical
End Sub

'' ==== دالة لحساب الحد الأقصى لطول النص بين أنواع التاريخ
Public Function GetMaxDateTypeLength() As Long
    Dim lngMaxLen As Long
    
    lngMaxLen = Len(DATE_TYPE_DAY)
    If Len(DATE_TYPE_MONTH) > lngMaxLen Then lngMaxLen = Len(DATE_TYPE_MONTH)
    If Len(DATE_TYPE_YEAR) > lngMaxLen Then lngMaxLen = Len(DATE_TYPE_YEAR)
    
    GetMaxDateTypeLength = lngMaxLen
End Function

'' ======= إنشاء الجدول مع الحقول والفهرسة =======
Private Sub CreateDateTable(db As DAO.Database)
    On Error Resume Next
    db.TableDefs.Delete TABLE_NAME
    On Error GoTo 0

    Dim tdf As DAO.TableDef
    Set tdf = db.CreateTableDef(TABLE_NAME)

    With tdf
        '' حقل الترقيم التلقائي
        Dim fld As DAO.Field
        Set fld = .CreateField("ID", dbLong)
        fld.Attributes = dbAutoIncrField
        .Fields.Append fld
        
        '' حقل الرقم
        Set fld = .CreateField("DateNo", dbLong)
        fld.Required = True
        .Fields.Append fld
        
        '' نوع التاريخ
        Set fld = .CreateField("DateType", dbText, GetMaxDateTypeLength())

        fld.Required = True
        .Fields.Append fld
    End With
    
    '' فهرس المفتاح الأساسي
    Dim idx As DAO.Index
    Set idx = tdf.CreateIndex("PrimaryKey")
    idx.Primary = True
    idx.Fields.Append idx.CreateField("ID")
    tdf.Indexes.Append idx
    
    '' فهرس فريد على التاريخ والنوع
    Set idx = tdf.CreateIndex("UniqueDateNoType")
    idx.Unique = True
    idx.Fields.Append idx.CreateField("DateNo")
    idx.Fields.Append idx.CreateField("DateType")
    tdf.Indexes.Append idx

    db.TableDefs.Append tdf

    Set fld = Nothing
    Set idx = Nothing
    Set tdf = Nothing
End Sub

'' ======= إنشاء أو تحديث الاستعلام لإنتاج كل التواريخ =======
Public Sub CreateOrUpdateDateGenerationQuery()
    On Error GoTo ErrorHandler

    Dim db As DAO.Database: Set db = CurrentDb
    Dim strSQL As String
    Dim qdf As DAO.QueryDef

    strSQL = "SELECT DateSerial(Years.DateNo, Months.DateNo, Days.DateNo) AS GeneratedDate " & _
             "FROM " & TABLE_NAME & " AS Days, " & _
             TABLE_NAME & " AS Months, " & _
             TABLE_NAME & " AS Years " & _
             "WHERE Days.DateType = '" & DATE_TYPE_DAY & "' " & _
             "AND Months.DateType = '" & DATE_TYPE_MONTH & "' " & _
             "AND Years.DateType = '" & DATE_TYPE_YEAR & "'"

    '' حذف الاستعلام لو موجود
    If QueryExists(QUERY_NAME) Then
        db.QueryDefs.Delete QUERY_NAME
    End If

    '' إنشاء الاستعلام
    Set qdf = db.CreateQueryDef(QUERY_NAME, strSQL)

    Application.RefreshDatabaseWindow
    
    Exit Sub

ErrorHandler:
    MsgBox "  خطأ أثناء إنشاء الاستعلام: " & Err.Description, vbCritical
End Sub

'' ======= التحقق من وجود جدول =======
Private Function TableExists(ByVal TableName As String) As Boolean
    On Error Resume Next
    TableExists = (Len(CurrentDb.TableDefs(TableName).Name) > 0)
    On Error GoTo 0
End Function

'' ======= التحقق من وجود استعلام =======
Private Function QueryExists(ByVal QueryName As String) As Boolean
    On Error Resume Next
    QueryExists = (Len(CurrentDb.QueryDefs(QueryName).Name) > 0)
    On Error GoTo 0
End Function

واخيرا يتم تعديل الاعدادت المناسبة لك و فقط يتم عمل كل شئ من تشغيل الإجراء التالى: TestGenerateDates