frmcalender.frm

很好的个人数字助理软件代码

      Height          =   495
      Index           =   33
      Left            =   3600
      Top             =   3000
      Width           =   615
   End
   Begin VB.Shape shapeDate 
      BackStyle       =   1  'Opaque
      Height          =   495
      Index           =   32
      Left            =   3000
      Top             =   3000
      Width           =   615
   End
   Begin VB.Shape shapeDate 
      BackStyle       =   1  'Opaque
      Height          =   495
      Index           =   31
      Left            =   2400
      Top             =   3000
      Width           =   615
   End
   Begin VB.Shape shapeDate 
      BackStyle       =   1  'Opaque
      Height          =   495
      Index           =   30
      Left            =   1800
      Top             =   3000
      Width           =   615
   End
   Begin VB.Shape shapeDate 
      BackStyle       =   1  'Opaque
      Height          =   495
      Index           =   29
      Left            =   1200
      Top             =   3000
      Width           =   615
   End
   Begin VB.Shape shapeDate 
      BackStyle       =   1  'Opaque
      Height          =   495
      Index           =   28
      Left            =   600
      Top             =   3000
      Width           =   615
   End
   Begin VB.Shape shapeDate 
      BackStyle       =   1  'Opaque
      Height          =   495
      Index           =   36
      Left            =   1200
      Top             =   3480
      Width           =   615
   End
   Begin VB.Shape shapeDate 
      BackStyle       =   1  'Opaque
      Height          =   495
      Index           =   35
      Left            =   600
      Top             =   3480
      Width           =   615
   End
End
Attribute VB_Name = "frmCalender"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

Public SelDate
Public strUsername
Public AMPM1
Public AMPM2
Public SelDateTmp
Public SelYearTmp

Private Sub Form_Load()
For I = 0 To 36
    shapeDate(I).BackColor = RGB(145, 155, 100)
Next I
For j = 0 To 36
    shapeAP1(j).BackColor = vbBlack
    shapeAP2(j).BackColor = vbBlack
    shapeAP1(j).Visible = False
    shapeAP2(j).Visible = False
Next j
SelDate = Day(Now)
Me.BackColor = RGB(145, 155, 100)
lstSchList.BackColor = RGB(145, 155, 100)
shapeCaption.BackColor = vbBlack
lblCaption.ForeColor = RGB(145, 155, 100)
shapeBack.BackColor = vbBlack
shapeNowDate.BackColor = RGB(145, 155, 100)
lblNowDate.Caption = Format(Date, "D/MMM/YYYY(DDD)")
shapePM.BackColor = RGB(145, 155, 100)
shapeCM.BackColor = RGB(145, 155, 100)
shapeNM.BackColor = RGB(145, 155, 100)
shapeMainMenu.BackColor = RGB(145, 155, 100)

strUsername = frmMain.lblUsername.Caption
CurrentMonth = Format(Date, "MMM")
CurrentYear = Year(Now)
IDs
lblYear.Caption = Year(Now)
lblMonth.Caption = Format(Date, "MMMM")

For j = 0 To 36
    If lblDate(j).Caption = Day(Now) Then
        shapeDate(j).BackColor = vbBlack
        lblDate(j).ForeColor = RGB(145, 155, 100)
    End If
Next j

Dim db As Database
Dim ReS As Recordset

Set db = OpenDatabase(App.Path + "\Data\" + strUsername + "\Sch.dat")
Set ReS = db.OpenRecordset(CurrentMonth)

On Error GoTo ErrHan
        txtDate.Text = ReS("Date")
        If Len(txtDate.Text) = 11 Then
            txtDate.SelStart = 7
            txtDate.SelLength = 4
        End If
        If Len(txtDate.Text) = 10 Then
            txtDate.SelStart = 6
            txtDate.SelLength = 4
        End If
Do
    txtDate.Text = ReS("Date")
    If Len(txtDate.Text) = 11 Then
        txtDate.SelStart = 0
        txtDate.SelLength = 2
        SelDateTmp = txtDate.SelText
        txtDate.SelStart = 7
        txtDate.SelLength = 4
        SelYearTmp = txtDate.SelText
    Else
        txtDate.SelStart = 0
        txtDate.SelLength = 1
        SelDateTmp = txtDate.SelText
        txtDate.SelStart = 6
        txtDate.SelLength = 4
        SelYearTmp = txtDate.SelText
    End If
    AMPM1 = ReS("AP1")
    AMPM2 = ReS("AP2")
    
    If SelDateTmp & SelYearTmp = SelDate & CurrentYear Then
        lstSchList.AddItem ReS("TF") & ReS("AP1") & "  " & ReS("Description")
    End If
    
    For I = 0 To 36
        If Len(txtDate.Text) = 11 Then
            txtDate.SelStart = 7
            txtDate.SelLength = 4
        Else
            txtDate.SelStart = 6
            txtDate.SelLength = 4
        End If
    If txtDate.SelText = CurrentYear Then
        If lblDate(I).Caption = SelDateTmp Then
            If AMPM1 = "AM" Then
                If shapeDate(I).BackColor = vbBlack Then
                    shapeAP1(I).BackColor = RGB(145, 155, 100)
                End If
                shapeAP1(I).Visible = True
            End If
            If AMPM1 = "PM" Then
                If shapeDate(I).BackColor = vbBlack Then
                    shapeAP2(I).BackColor = RGB(145, 155, 100)
                End If
                shapeAP2(I).Visible = True
            End If
            If AMPM2 = "AM" Then
                If shapeDate(I).BackColor = vbBlack Then
                    shapeAP1(I).BackColor = RGB(145, 155, 100)
                End If
                shapeAP1(I).Visible = True
            End If
            If AMPM2 = "PM" Then
                If shapeDate(I).BackColor = vbBlack Then
                    shapeAP2(I).BackColor = RGB(145, 155, 100)
                End If
                shapeAP2(I).Visible = True
            End If
        End If
    End If
    Next I
    ReS.MoveNext
Loop

ReS.Close
db.Close

Set ReS = Nothing
Set db = Nothing


ErrHan:
If Err.Number = 3021 Then
    Exit Sub
End If
End Sub

Private Sub lblCaptionSupport_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
DragForm Me
End Sub

Private Sub lblCMSupport_Click()
For I = 0 To 36
    shapeAP1(I).Visible = False
    shapeAP2(I).Visible = False
Next I
lstSchList.Clear
CurrentMonth = Format(Date, "MMM")
lblMonth.Caption = Format(Date, "MMMM")
CurrentYear = Year(Now)
lblYear.Caption = CurrentYear
IDs
For I = 0 To 36
    If lblDate(I).Caption = Day(Now) Then
        shapeDate(I).BackColor = vbBlack
        lblDate(I).ForeColor = RGB(145, 155, 100)
    End If
Next I
SelDate = Day(Now)

Dim db As Database
Dim ReS As Recordset

Set db = OpenDatabase(App.Path + "\Data\" + strUsername + "\Sch.dat")
Set ReS = db.OpenRecordset(CurrentMonth)

On Error GoTo ErrHan
        txtDate.Text = ReS("Date")
        If Len(txtDate.Text) = 11 Then
            txtDate.SelStart = 7
            txtDate.SelLength = 4
        Else
            txtDate.SelStart = 6
            txtDate.SelLength = 4
        End If
        If txtDate.SelText <> CurrentYear Then
            ReS.Close
            db.Close
            Set ReS = Nothing
            Set db = Nothing
            Exit Sub
        End If
Do
    txtDate.Text = ReS("Date")
    If Len(txtDate.Text) = 11 Then
        txtDate.SelStart = 0
        txtDate.SelLength = 2
        SelDateTmp = txtDate.SelText
        txtDate.SelStart = 7
        txtDate.SelLength = 4
        SelYearTmp = txtDate.SelText
    Else
        txtDate.SelStart = 0
        txtDate.SelLength = 1
        SelDateTmp = txtDate.SelText
        txtDate.SelStart = 6
        txtDate.SelLength = 4
        SelYearTmp = txtDate.SelText
    End If
    
    If SelDateTmp & SelYearTmp = SelDate & CurrentYear Then
        lstSchList.AddItem ReS("TF") & ReS("AP1") & "  " & ReS("Description")
    End If
    
    For I = 0 To 36
        If Len(txtDate.Text) = 11 Then
            txtDate.SelStart = 7
            txtDate.SelLength = 4
        Else
            txtDate.SelStart = 6
            txtDate.SelLength = 4
        End If
    If txtDate.SelText = CurrentYear Then
        If lblDate(I).Caption = SelDateTmp Then
            If AMPM1 = "AM" Then
                If shapeDate(I).BackColor = vbBlack Then
                    shapeAP1(I).BackColor = RGB(145, 155, 100)
                End If
                shapeAP1(I).Visible = True
            End If
            If AMPM1 = "PM" Then
                If shapeDate(I).BackColor = vbBlack Then
                    shapeAP2(I).BackColor = RGB(145, 155, 100)
                End If
                shapeAP2(I).Visible = True
            End If
            If AMPM2 = "AM" Then
                If shapeDate(I).BackColor = vbBlack Then
                    shapeAP1(I).BackColor = RGB(145, 155, 100)
                End If
                shapeAP1(I).Visible = True
            End If
            If AMPM2 = "PM" Then
                If shapeDate(I).BackColor = vbBlack Then
                    shapeAP2(I).BackColor = RGB(145, 155, 100)
                End If
                shapeAP2(I).Visible = True
            End If
        End If
    End If
    Next I
    ReS.MoveNext
Loop

ReS.Close
db.Close

Set ReS = Nothing
Set db = Nothing

ErrHan:
If Err.Number = 3021 Then
    Exit Sub
End If
End Sub

Private Sub lblCMSupport_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
lblCM.ForeColor = RGB(145, 155, 100)
shapeCM.BackColor = vbBlack
End Sub

Private Sub lblCMSupport_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
shapeCM.BackColor = RGB(145, 155, 100)
lblCM.ForeColor = vbBlack
End Sub

Private Sub lblDate_Click(Index As Integer)
If lblDate(Index).Caption = "" Then
    Exit Sub
End If
SelDate = lblDate(Index).Caption
For I = 0 To 36
    lblDate(I).ForeColor = vbBlack
Next I
If CurrentMonth & CurrentYear = Format(Date, "MMM") & Year(Now) Then
For j = 0 To 36
    If lblDate(j).Caption = Day(Now) Then
        lblDate(j).ForeColor = RGB(145, 155, 100)
    End If
Next j
End If

Dim db As Database
Dim ReS As Recordset

Set db = OpenDatabase(App.Path + "\Data\" + strUsername + "\Sch.dat")
Set ReS = db.OpenRecordset(CurrentMonth)

On Error GoTo ErrHan
lstSchList.Clear
Do

txtDate.Text = ReS("Date")

If Len(txtDate.Text) = 11 Then
    txtDate.SelStart = 0
    txtDate.SelLength = 2
    SelDateTmp = txtDate.SelText
    txtDate.SelStart = 7
    txtDate.SelLength = 4
    SelYearTmp = txtDate.SelText
End If
If Len(txtDate.Text) = 10 Then
    txtDate.SelStart = 0
    txtDate.SelLength = 1
    SelDateTmp = txtDate.SelText
    txtDate.SelStart = 6
    txtDate.SelLength = 4
    SelYearTmp = txtDate.SelText
End If
    
If SelDateTmp & SelYearTmp = SelDate & CurrentYear Then
    lstSchList.AddItem ReS("TF") & ReS("AP1") & "  " & ReS("Description")
    ReS.MoveNext
Else
    ReS.MoveNext
End If
Loop

ErrHan:
    If Err.Number = 3021 Then
        Exit Sub
    End If
End Sub

Private Sub lblDate_DblClick(Index As Integer)
SchDate = lblDate(Index).Caption
SchMonth = CurrentMonth
SchYear = CurrentYear
frmFullSch.Show
Me.Hide
End Sub

Private Sub lblDate_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 2 Then
    SchMonth = CurrentMonth
    SchDate = lblDate(Index).Caption
    SchYear = CurrentYear
    PopupMenu frmMenu.mnuDates
End If
End Sub

Private Sub lblMainMenuSupport_Click()
frmMain.Show
Unload Me
End Sub

Private Sub lblMainMenuSupport_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
lblMainMenu.ForeColor = RGB(145, 155, 100)
shapeMainMenu.BackColor = vbBlack
End Sub

Private Sub lblMainMenuSupport_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
shapeMainMenu.BackColor = RGB(145, 155, 100)
lblMainMenu.ForeColor = vbBlack
End Sub

Private Sub lblNMSupport_Click()
lstSchList.Clear
For j = 0 To 36
    shapeAP1(j).Visible = False
    shapeAP2(j).Visible = False
Next j
For I = 0 To 36
    shapeDate(I).BackColor = RGB(145, 155, 100)
    lblDate(I).ForeColor = vbBlack
Next I
If CurrentMonth = "Jan" Then
    CurrentMonth = "Feb"
    lblMonth.Caption = "February"
ElseIf CurrentMonth = "Feb" Then
    CurrentMonth = "Mar"
    lblMonth.Caption = "March"
ElseIf CurrentMonth = "Mar" Then
    CurrentMonth = "Apr"
    lblMonth.Caption = "April"
ElseIf CurrentMonth = "Apr" Then
    CurrentMonth = "May"
    lblMonth.Caption = "May"
ElseIf CurrentMonth