| |
>早速コードをコピーして実行してみましたら、
>RS.FindFirst "出席日=#" & Split(.Tag, "#")(1) & "#"
>のところで、「インデックスが有効範囲にありません」と表示されます。
Tagプロパティには日付がそのままは行ってますので、Splitで
取り出す必要は有りません。
RS.FindFirst "出席日=#" & .Tag & "#"
>下記のすべてのsub、functionを記述すればよいのですよね？
>Private Sub Form_Load()
>Private Function Day_Click(D As Date)
>Private Function SetCalendar(y As Integer, m As Integer)
>
>Private Sub Form_Current()
>Private Sub CalUpdate(y As Integer, m As Integer)
>Private Sub SetColor(y As Integer, m As Integer)
アップしたときに、こちらでサンプル用に作ったのとごっちゃになってました。
フォームに必要なコードは下記がすべてです。
Private Sub Form_Load()
SetCalendar Year(Date), Month(Date)
End Sub
Private Sub Form_Current()
SetColor Year(Date), Month(Date)
End Sub
Private Function Day_Click(D As Date)
Screen.ActiveControl.Value = D
End Function
Private Sub SetCalendar(y As Integer, m As Integer)
Dim i As Integer, j As Integer, FirstDay As Date, s As Integer
For j = -3 To 2
FirstDay = DateSerial(y, m + j, 1)
s = Weekday(FirstDay)
For i = 0 To Day(DateSerial(y, m + j + 1, -1))
With Me(Chr(Asc("d") + j) & i + s)
.Caption = Day(FirstDay + i)
.OnClick = "=Day_Click(#" & FirstDay + i & "#)"
.Tag = FirstDay + i
End With
Next
Next
End Sub
Private Sub SetColor(y As Integer, m As Integer)
Dim i As Integer, j As Integer
Dim db As DAO.Database
Dim RS As DAO.Recordset
Dim strSQL As String
strSQL = "SELECT * FROM 出欠 " & _
"WHERE 出席日 Between #" & DateSerial(y, m + 0, 1) & _
"# AND #" & DateSerial(y, m + 2, 0) & "#"
Set db = CurrentDb()
Set RS = db.OpenRecordset(strSQL, dbOpenDynaset, dbReadOnly)
For j = -3 To 2
For i = 1 To 42
With Me(Chr(Asc("d") + j) & i)
If .Tag = "" Then
.BackColor = vbWhite
Else
RS.FindFirst "出席日=#" & .Tag & "#"
If RS.NoMatch Then
If WeekdayName(Weekday(.Tag)) = Me.曜日 Then
.BackColor = vbMagenta
Else
.BackColor = vbWhite
End If
ElseIf RS!出欠 Then
.BackColor = vbBlue
Else
.BackColor = vbRed
End If
End If
End With
Next
Next
RS.Close
End Sub
まったく同じサンプルは作ってないので、
まだ、おかしなところがあるかも知れませんが、
たぶんこれでいいと思います。
|
|
hatena
- 07/7/9(月) 11:38 -
![[未読]](./data/access/image/read_icon.gif){kind=icon}
