عاوز اعمل تقويم السنة الميلادية على نموذج الاكسس

[mom20088]

السلام عليكم

محتاج اعمل قاعدة بيانات فيها تقويم السنة الميلادية زى الاكسل كده

وتكون النتيجة عبارة عن شهور السنة مثلا سنة 2016 

ويتكتب فى كل يوم من ايام النتيجة اعمال الانتاج

شكرا

 

مرفق صورة من طلبى

New Microsoft Access Database.rar

تم تعديل يونيو 23, 2016 بواسطه mom20088
اضافة صورة

[ابوخليل]

انظر هنا   من بعض لمسات نارت لبزو

[mom20088]

انا محتاج مساعدتك يا أستاذنا

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

 

Private Sub PopulateCalendar()
On Error GoTo Err_PopulateCalendar

Dim strFirstOfMonth As String, bytFirstWeekdayOfMonth As Byte, bytBlockCounter As Byte
Dim bytBlockDayOfMonth As Byte, lngBlockDate As Long, ctlDayBlock As Control
Dim bytDaysInMonth As Byte, bytEventDayOfMonth As Byte, lngFirstOfMonth As Long
Dim lngLastOfMonth As Long, lngFirstOfNextMonth As Long, lngLastOfPreviousMonth As Long
Dim lngEventDate As Long, bytBlankBlocksBefore As Byte, bytBlankBlocksAfter As Byte
Dim astrCalendarBlocks(1 To 42) As String, dB As Database, rstEvents As Recordset
Dim strSelectEvents As String, strEvent As String, strPlatoons As String
Dim intMonth As Integer, intYear As Integer, lngSystemDate As Long  'CFB added 1-25-08
Dim ctlSystemDateBlock As Control, blnSystemDateIsShown As Boolean  'CFB added 1-25-08
Dim strSQL As String    'Added 4/16/2008
Dim blnRetVal

lngSystemDate = Date    'CFB added 1-25-08
intMonth = objCurrentDate.Month
intYear = objCurrentDate.Year
lstEvents.Visible = False
lblEventsOnDate.Visible = False
lblMonth.caption = MonthAndYear(intMonth, intYear)
strFirstOfMonth = Str(intMonth) & "/1/" & Str(intYear)
  'ADezii
  'NOTE: Will work in the UK (United Kingdom) and other European Nations
'strFirstOfMonth = "1/" & Str(intMonth) & Str(intYear)
bytFirstWeekdayOfMonth = Weekday(strFirstOfMonth)
lngFirstOfMonth = DateSerial(intYear, intMonth, 1)
lngFirstOfNextMonth = DateSerial(intYear, intMonth + 1, 1)
lngLastOfMonth = lngFirstOfNextMonth - 1
lngLastOfPreviousMonth = lngFirstOfMonth - 1
bytDaysInMonth = lngFirstOfNextMonth - lngFirstOfMonth
bytBlankBlocksBefore = bytFirstWeekdayOfMonth - 1
bytBlankBlocksAfter = 42 - (bytBlankBlocksBefore + bytDaysInMonth)
    
Set dB = CurrentDb

strSQL = "SELECT * From Production "
strSQL = strSQL & "WHERE Production.[Production Date] Between " & lngFirstOfMonth & " And " & lngLastOfMonth & _
                  " ORDER BY Production.[Production Order];"

Set rstEvents = dB.OpenRecordset(strSQL, dbOpenDynaset, dbSeeChanges)    'Added 4/16/2008

Do While Not rstEvents.EOF
  strEvent = "[" & rstEvents![Production Order] & "] - "
  bytEventDayOfMonth = (rstEvents!Production_Date - lngLastOfPreviousMonth)
  bytBlockCounter = bytEventDayOfMonth + bytBlankBlocksBefore
    If astrCalendarBlocks(bytBlockCounter) <> "" Then
      astrCalendarBlocks(bytBlockCounter) = _
      astrCalendarBlocks(bytBlockCounter) & vbNewLine & strEvent
    Else
      astrCalendarBlocks(bytBlockCounter) = strEvent
    End If
    rstEvents.MoveNext
Loop
    
For bytBlockCounter = 1 To 42                       'blank blocks at start of month
  Select Case bytBlockCounter
    Case Is < bytFirstWeekdayOfMonth
      astrCalendarBlocks(bytBlockCounter) = ""
      ReferenceABlock ctlDayBlock, bytBlockCounter
      ctlDayBlock.BackColor = 12632256
      ctlDayBlock = ""
      ctlDayBlock.Enabled = False
      ctlDayBlock.Tag = ""
    Case Is > bytBlankBlocksBefore + bytDaysInMonth 'blank blocks at end of month
      astrCalendarBlocks(bytBlockCounter) = ""
      ReferenceABlock ctlDayBlock, bytBlockCounter
      ctlDayBlock.BackColor = 12632256
      ctlDayBlock = ""
      ctlDayBlock.Enabled = False
      ctlDayBlock.Tag = ""
        If bytBlankBlocksAfter > 6 And bytBlockCounter > 35 Then
          ctlDayBlock.Visible = False
        End If
    Case Else   'blocks that hold days of the month
      bytBlockDayOfMonth = bytBlockCounter - bytBlankBlocksBefore
      ReferenceABlock ctlDayBlock, bytBlockCounter
      lngBlockDate = lngLastOfPreviousMonth + bytBlockDayOfMonth 'block's date
        If bytBlockDayOfMonth < 10 Then
          ctlDayBlock = Space(2) & bytBlockDayOfMonth & _
                        vbNewLine & astrCalendarBlocks(bytBlockCounter)
        Else
          ctlDayBlock = bytBlockDayOfMonth & _
                        vbNewLine & astrCalendarBlocks(bytBlockCounter)
        End If
            
        'If this block is the system date, change its color (CFB 1-25-08)
        If lngBlockDate = lngSystemDate Then
          ctlDayBlock.BackColor = QBColor(13)
          ctlDayBlock.ForeColor = QBColor(15)
          Set ctlSystemDateBlock = ctlDayBlock
          blnSystemDateIsShown = True
        Else
          ctlDayBlock.BackColor = 16777215
          ctlDayBlock.ForeColor = 8388608 '====> Added by ADezii on 1/28/2008 (Date
        End If                                  'Text was essentially invisible without it for
          ctlDayBlock.Visible = True            'Block representing current day position)
          ctlDayBlock.Enabled = True
          ctlDayBlock.Tag = lngBlockDate
  End Select
Next
    
'If the system date is in this month, show its events (CFB added 1-25-08)
If blnSystemDateIsShown Then
  PopulateEventsList ctlSystemDateBlock
End If
    
Call PopulateYearListBox    'Added by ADezii on 1/28/2008 - suggested by CFB

Exit_PopulateCalendar:
  Exit Sub
Err_PopulateCalendar:
  MsgBox Err.Description, vbExclamation, "Error inPopulateCalendar()"
  Resume Exit_PopulateCalendar
End Sub