在Access 2010中创建日历

Question

我一直在拼命地想找到一种方法在Access中制作日历。我知道这是可以做到的，因为我见过一些很好的例子，但我不知道怎么做。(另外，我的VB知识很少。)

基本上，我希望日历能够显示程序(我们称之为胶囊)何时被借出以及何时将被归还的一系列日期。

• DateReserve -胶囊被保留的日期
• DateReturn -胶囊需要返回的日期。

例如，如果胶囊A在2014年6月1日被预订，并将于2014年6月14日返回，我希望日历能直观地显示胶囊A在这段时间内不可用。这样，我们就不会不小心重复预定一个胶囊。

通过我的许多谷歌搜索之一，我发现VB代码拉出一个非常漂亮的日历。我只是不能正确地使用代码来直观地显示胶囊不可用的日期。下面是我无法正常工作的一段代码:

Private Sub OpenContinuousForm(ctlName As String)
Dim ctlValue As Integer
Dim DaysOfMonth As Long
Dim DateReturn As Date
Dim DateShipOut As Date
Dim DateRangeForProgram As String
DateRangeForProgram = (DateDiff("n", [DateReturn], [DateShipOut]))
On Error GoTo ErrorHandler
ctlValue = Me.Controls(ctlName).Tag
DaysOfMonth = MyArray(ctlValue - 1, 0)
DoCmd.OpenForm "frmCapsulesSchedule", acNormal, , [DateRangeForProgram] = DaysOfMonth
ExitSub:
    Exit Sub
ErrorHandler:
    MsgBox "DATE SHIP OUT FAILED.", , "Error!!!"
    Resume ExitSub
End Sub

如果您需要进一步的信息，请告诉我。

Answer 1

下面是我用于日历的代码;任何你看到"老师"、"学校"或"胶囊"的地方，你都可以把你自己的信息放在那里:

Option Compare Database
Option Explicit
Private intYear As Integer
Private intMonth As Integer
Private lngFirstDayOfMonth As Long
Private intLastDayOfLastMonth As Integer
Private intFirstWeekday As Integer
Private intDaysInMonth As Integer
Private strFormReference As String
Private MyArray() As Variant
Private Sub cboMonth_Click()
On Error GoTo Errorhandler
Call Main
ExitSub:
    Exit Sub
Errorhandler:
    MsgBox "There has been an error. Please reload the form.", , "Error"
    Resume ExitSub
End Sub
Private Sub cboYear_AfterUpdate()
On Error GoTo Errorhandler
Call Main
ExitSub:
    Exit Sub
Errorhandler:
    MsgBox "There has been an error. Please reload the form.", , "Error"
    Resume ExitSub
End Sub
Private Sub Form_Load()
On Error GoTo Errorhandler
'Set the month and date to this current month and date
With Me
    .cboMonth = Month(Date)
    .cboYear = Year(Date)
End With
Call Main
ExitSub:
    Exit Sub
Errorhandler:
    MsgBox "There has been an error. Please reload the form.", , "Error"
    Resume ExitSub
End Sub
Public Sub InitVariables()
On Error GoTo Errorhandler
intYear = Me.cboYear
intMonth = Me.cboMonth
lngFirstDayOfMonth = CLng(DateSerial(intYear, intMonth, 1))
intFirstWeekday = getFirstWeekday(lngFirstDayOfMonth)
intDaysInMonth = getDaysInMonth(lngFirstDayOfMonth)
'This is where you add the reference for the form
'It is used in case we wish to add the module to a subform
ExitSub:
    Exit Sub
Errorhandler:
    MsgBox "There has been an error. Please reload the form.", , "Error"
    Resume ExitSub
End Sub
Public Sub Main()
On Error GoTo Errorhandler
Call InitVariables
Call InitArray
Call LoadArray
Call PrintArray
ExitSub:
    Exit Sub
Errorhandler:
    MsgBox "There has been an error. Please reload the form.", , "Error"
    Resume ExitSub
End Sub
Public Sub InitArray()
'First column will add all dates of the array
'Second column will add visible property
'Third column will hold the string variable
Dim i As Integer
On Error GoTo Errorhandler
ReDim MyArray(0 To 41, 0 To 3)
For i = 0 To 41
    MyArray(i, 0) = lngFirstDayOfMonth + 1 - intFirstWeekday + i
    If Month(MyArray(i, 0)) = intMonth Then
        MyArray(i, 1) = True
        'This works out the days of the month
        MyArray(i, 2) = i + 2 - intFirstWeekday & vbNewLine
    Else
        MyArray(i, 1) = False
    End If
   
Next i
ExitSub:
    Exit Sub
Errorhandler:
    MsgBox "There has been an error. Please reload the form.", , "Error"
    Resume ExitSub
End Sub
Public Sub LoadArray()
'This sub loads an array with the relevant variables from a query
Dim db As Database
Dim rs As Recordset
Dim rsFiltered As Recordset
Dim strQuery As String
Dim i As Integer
On Error GoTo ErrorHandler1
strQuery = "Select * FROM [qryDatesYearsCapsules2]"
Set db = CurrentDb
Set rs = db.OpenRecordset(strQuery)

With rs
    If Not rs.BOF And Not rs.EOF Then
    'Ensures the recordset contains records
  
  On Error GoTo ErrorHandler2
        For i = 0 To UBound(MyArray)
        'Will loop through the array and use dates to filter down the query
        'It firsts checks that the second column has true for its visible property
            If MyArray(i, 1) = True Then
                .Filter = "[NewDate]=" & MyArray(i, 0)
                'To filter you must open a secondary recordset and
                'Use that as the basis for a query
                'This makes sense as you are building a query on a query
                Set rsFiltered = .OpenRecordset
                If Not rsFiltered.BOF And Not rsFiltered.EOF Then
                    'If the recordset is not empty then you are able
                    'to extract the text from the values provided
                    Do While Not rsFiltered.EOF = True
                        MyArray(i, 2) = MyArray(i, 2) & rsFiltered!CapsuleSet
           '             MyArray(i, 2) = MyArray(i, 2) & vbNewLine & rsFiltered!Teacher
                        MyArray(i, 2) = MyArray(i, 2) & vbNewLine & rsFiltered!School
           '             MyArray(i, 2) = MyArray(i, 2) & " - " & rsFiltered!NewDate
                        MyArray(i, 2) = MyArray(i, 2) & vbNewLine & vbNewLine
                        
                    rsFiltered.MoveNext
                    Loop
                End If
            End If
     
        Next i
    
End If
    .Close
End With
ExitSub:
    Set db = Nothing
    Set rs = Nothing
    Exit Sub
ErrorHandler1:
    MsgBox "There has been an error. Please reload the form.", , "Error"
    Resume ExitSub
    
ErrorHandler2:
    MsgBox "There has been an error. Please reload the form.", , "Error"
    Resume ExitSub
    
End Sub
Public Sub PrintArray()
Dim strTextBox As String
Dim i As Integer
On Error GoTo Errorhandler
For i = 0 To 41
    strTextBox = "txt" & CStr(i + 1)
    With Me
        Controls(strTextBox) = ""
        Controls(strTextBox).tag = i + 1
        Controls(strTextBox) = MyArray(i, 2)
    'Debug.Print strTextBox
    'MyArray(i, 2)
    End With
Next i
ExitSub:
    Exit Sub
Errorhandler:
    MsgBox "There has been an error. Please reload the form.", , "Error"
    Resume ExitSub
End Sub
Private Sub OpenContinuousForm(ctlName As String)
Dim ctlValue As Integer
Dim DayOfMonth As Long
On Error GoTo Errorhandler
ctlValue = Me.Controls(ctlName).tag
DayOfMonth = MyArray(ctlValue - 1, 0)
DoCmd.OpenForm "frmClassDataEntry", acNormal, , "[NewDate]=" & DayOfMonth, , acDialog
ExitSub:
    Exit Sub
Errorhandler:
    MsgBox "There has been an error. Please reload the form.", , "Error"
    Resume ExitSub
End Sub
Private Sub txt1_Click()
On Error GoTo Errorhandler
If Me.ActiveControl.Text <> "" Then
    Call OpenContinuousForm(Me.ActiveControl.Name)
End If
ExitSub:
    Exit Sub
Errorhandler:
    MsgBox "There has been an error. Please reload form."
    Resume ExitSub
End Sub

'将txt1_Click()的代码一直重复到txt42_Click()

Private Sub Format()
  Dim ctl As Control
  Dim lngBackColor As Long
  For Each ctl In Me.Detail.Controls
    If DCount("*", "lstCapsules", "[Capsule]='" & ctl.Value & "'") = 0 Then
       lngBackColor = 16777215
    Else
       lngBackColor = DLookup("Background", "lstCapsules", "[Capsule]='" & ctl.Value & "'")
    End If
    ctl.BackColor = lngBackColor
    
    Next ctl
    
  Set ctl = Nothing
  
End Sub

我也有一个模块叫modFunctions:

    Option Compare Database
Option Explicit
Public Function getFirstWeekday(lngFirstDayOfMonth As Long) As Integer
On Error GoTo Errorhandler
getFirstWeekday = -1
getFirstWeekday = Weekday(lngFirstDayOfMonth, vbMonday)
ExitFunction:
    Exit Function
Errorhandler:
    getFirstWeekday = 0
    MsgBox "There has been an error. Please reload the form.", , "Error"
    Resume ExitFunction
End Function
Public Function getDaysInMonth(lngFirstDayOfMonth As Long) As Integer
On Error GoTo Errorhandler
getDaysInMonth = -1
getDaysInMonth = DateDiff("d", lngFirstDayOfMonth, DateAdd("m", 1, lngFirstDayOfMonth))
ExitFunction:
    Exit Function
Errorhandler:
    getDaysInMonth = 0
    MsgBox "Something is wrong with the DATES!.", , "Date Error"
    Resume ExitFunction
End Function

Answer 2

我在Access All In One网站上看到了一个非常有用的youtube视频。下面是指向示例

Answer 3

您在openform命令的Where条件中的语法错误。

它应该是"[DateRangeForProgram]=" & DaysOfMonth，如果字段你用来过滤表单的记录源是[DateRangeForProgram]。

另外，如果您试图将表单打开到多个天，您可能应该使用Between操作符。datediff函数的第一个参数指定了一个间隔，而您的间隔是分钟。

你应该把剩下的代码贴出来，这样整个场景就清楚了。