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

خطأ فى تنفيذ كود تقويم سنة ميلادية


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

Calendar_MeetingDate.jpg

ConfCtr_Smpl.zip

New Microsoft Access Database - Copy.rar

رابط هذا التعليق
شارك

اخى العزيز

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

من فضلك حاول تساعدنى

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

الكمية المنتجة - اسم المنتج - تاريخ الانتاج وتاريخ الانتهاء 

والايام اللى مفيهاش انتاج يكتب فيها " لا يوجد انتاج"

اشكرك يا اخى العزيز

fin - Copy.rar

تم تعديل بواسطه mom20088
توضيح
رابط هذا التعليق
شارك

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information