其他数据库

开发平台：
Visual Basic

frmRiLi.frm：源码内容
							VERSION 5.00
Object = "{5E9E78A0-531B-11CF-91F6-C2863C385E30}#1.0#0"; "MSFLXGRD.OCX"
Object = "{FE0065C0-1B7B-11CF-9D53-00AA003C9CB6}#1.1#0"; "COMCT232.OCX"
Begin VB.Form frmRiLi 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "日历"
   ClientHeight    =   2985
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   4485
   ControlBox      =   0   'False
   BeginProperty Font 
      Name            =   "宋体"
      Size            =   10.5
      Charset         =   134
      Weight          =   400
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   Icon            =   "frmRiLi.frx":0000
   KeyPreview      =   -1  'True
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   2985
   ScaleWidth      =   4485
   StartUpPosition =   2  '屏幕中心
   Begin VB.CommandButton Command1 
      Caption         =   "确定(&K)"
      Height          =   435
      Left            =   3120
      TabIndex        =   3
      Top             =   75
      Width           =   1275
   End
   Begin VB.PictureBox PicMonth 
      BackColor       =   &H00FFFFFF&
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   9
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   405
      Left            =   1665
      ScaleHeight     =   345
      ScaleWidth      =   810
      TabIndex        =   5
      Top             =   90
      Width           =   870
      Begin ComCtl2.UpDown VScrollMonth 
         Height          =   360
         Left            =   540
         TabIndex        =   10
         Top             =   -15
         Width           =   270
         _ExtentX        =   476
         _ExtentY        =   635
         _Version        =   327681
         BuddyControl    =   "txtMonth"
         BuddyDispid     =   196611
         OrigLeft        =   540
         OrigRight       =   810
         OrigBottom      =   360
         SyncBuddy       =   -1  'True
         Wrap            =   -1  'True
         BuddyProperty   =   65547
         Enabled         =   -1  'True
      End
      Begin VB.TextBox txtMonth 
         Alignment       =   2  'Center
         Appearance      =   0  'Flat
         BorderStyle     =   0  'None
         BeginProperty Font 
            Name            =   "宋体"
            Size            =   12
            Charset         =   134
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   360
         Left            =   60
         MaxLength       =   2
         TabIndex        =   2
         Text            =   "3"
         Top             =   60
         Width           =   420
      End
   End
   Begin VB.PictureBox picYear 
      BackColor       =   &H00FFFFFF&
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   9
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   405
      Left            =   105
      ScaleHeight     =   345
      ScaleWidth      =   1080
      TabIndex        =   4
      Top             =   90
      Width           =   1140
      Begin ComCtl2.UpDown VScrollYear 
         Height          =   375
         Left            =   810
         TabIndex        =   9
         Top             =   -15
         Width           =   270
         _ExtentX        =   476
         _ExtentY        =   661
         _Version        =   327681
         BuddyControl    =   "txtYear"
         BuddyDispid     =   196613
         OrigLeft        =   810
         OrigTop         =   15
         OrigRight       =   1080
         OrigBottom      =   390
         SyncBuddy       =   -1  'True
         Wrap            =   -1  'True
         BuddyProperty   =   65547
         Enabled         =   -1  'True
      End
      Begin VB.TextBox txtYear 
         Alignment       =   2  'Center
         Appearance      =   0  'Flat
         BorderStyle     =   0  'None
         BeginProperty Font 
            Name            =   "宋体"
            Size            =   12
            Charset         =   134
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   360
         Left            =   105
         MaxLength       =   4
         TabIndex        =   1
         Text            =   "2000"
         Top             =   45
         Width           =   555
      End
   End
   Begin MSFlexGridLib.MSFlexGrid msfGrid 
      Height          =   2400
      Left            =   0
      TabIndex        =   0
      Top             =   615
      Width           =   4485
      _ExtentX        =   7911
      _ExtentY        =   4233
      _Version        =   393216
      Rows            =   7
      Cols            =   7
      FixedCols       =   0
      BackColorFixed  =   12648447
      ForeColorFixed  =   192
      BackColorSel    =   12582912
      AllowBigSelection=   0   'False
      TextStyleFixed  =   3
      HighLight       =   0
      FillStyle       =   1
      ScrollBars      =   0
      FormatString    =   "dddd"
   End
   Begin VB.TextBox txtFocus 
      Height          =   315
      Left            =   1470
      TabIndex        =   8
      Text            =   "Text1"
      Top             =   1830
      Width           =   855
   End
   Begin VB.Label Label2 
      AutoSize        =   -1  'True
      BackColor       =   &H00C0C0C0&
      Caption         =   "月"
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   12
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   240
      Left            =   2580
      TabIndex        =   7
      Top             =   195
      Width           =   240
   End
   Begin VB.Label Label1 
      AutoSize        =   -1  'True
      BackColor       =   &H00C0C0C0&
      Caption         =   "年"
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   12
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   240
      Left            =   1365
      TabIndex        =   6
      Top             =   195
      Width           =   240
   End
End
Attribute VB_Name = "frmRiLi"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Public mRetDate As String
Dim mOldRow As Integer
Dim mOldCol As Integer
Dim mCurDay As Integer
Dim misToCheckMouse As Boolean '是否检查mouserow,mousecol
Dim misRefresh As Boolean '要不要刷新行和列,在RefreshDayList更换行列时 不misrefresh=false
Dim misStart As Boolean '判断是否刚开始,开始的时候不刷新RefreshDayList
Dim mSelDate As Integer '选择的日期
Private Sub Command1_Click()
'    Dim tmpDate As String
'    Select Case Trim(Me.Tag)
'        Case UCase("frmMain")
'            tmpDate = getDate
'            frmMain.mRetDate = tmpDate
'    End Select
    mRetDate = getDate
    Me.Hide
End Sub
Private Function getDate() As String
    getDate = Format(DateSerial(Val(txtYear), Val(txtMonth), _
                Val(msfGrid.TextMatrix(msfGrid.row, msfGrid.col))), _
                "yyyy-mm-dd")
End Function
Private Sub Form_Activate()
    misToCheckMouse = False
    misRefresh = False
    misStart = True
    mSelDate = Day(Date)
    mCurDay = mSelDate 'Day(Date)
    txtYear = Year(Date)
    txtMonth = Month(Date)
    IniVscroll
    iniGrid
    misStart = False
    RefreshDayList
End Sub
Private Sub IniVscroll()
    With VScrollYear
        .Max = 9999
        .Min = 1919
        .Increment = 1
        '.SmallChange = 1
        .Value = Year(Date)
    End With
    With VScrollMonth
        .Max = 12
        .Min = 1
        '.LargeChange = 1
        .Increment = 1
        .Value = Month(Date)
    End With
End Sub
Private Sub iniGrid()
    With msfGrid
        .Rows = 7
        .Cols = 7
        .FixedRows = 1
        .FixedCols = 0
        .Height = 2406
        .Width = 4480
        .BackColorFixed = &HC0E0FF
        .BackColorSel = &H8000000D 'vbWhite
        .ForeColorSel = vbWhite
        .BackColorBkg = &H8000000E
        .ForeColorFixed = &HC0&      '&HFF&
        .FormatString = "^日" & vbTab _
                        & "^一" & vbTab _
                        & "^二" & vbTab _
                        & "^三" & vbTab _
                        & "^四" & vbTab _
                        & "^五" & vbTab _
                        & "^六" & vbTab
        Dim I As Integer
        For I = 0 To .Rows - 1
            If I = 0 Then
                .RowHeight(I) = 336
            Else
                .RowHeight(I) = 336
            End If
            
        Next
        For I = 0 To .Cols - 1
            .ColWidth(I) = 625
        Next
    End With
End Sub
'Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
'    If UnloadMode = vbFormControlMenu Then
'        Select Case Trim(Me.Tag)
'            Case UCase("frmMain")
'                frmMain.mRetDate = getDate
'        End Select
'    End If
'End Sub
Private Sub msfGrid_Click()
    With msfGrid
        If Trim(.TextMatrix(.row, .col)) <> Empty Then
            mSelDate = Val(.TextMatrix(.row, .col))
        End If
    End With
End Sub
Private Sub RefreshDayList()
    Dim MaxDay As Integer
    Dim FirstWeekDay As Integer
    Dim DayRow As Integer
    Dim DayCol As Integer
    Dim I As Integer
    With msfGrid
        If Trim(txtYear) <> Empty And Trim(txtMonth) <> Empty Then
            MaxDay = GetMaxDayInAMonth(Val(txtYear), Val(txtMonth))
            FirstWeekDay = Weekday(DateSerial(Val(txtYear), Val(txtMonth), 1))
            DayRow = 1
            DayCol = FirstWeekDay - 1
            For I = 0 To DayCol - 1
                '.TextArray(DayRow * 7 + i) = ""
                .TextArray(faIndex(DayRow, I)) = ""
            Next I
            
            .Cols = 7
            .Rows = 7
            setGridText DayCol, 1, MaxDay, False, msfGrid
            setGridText DayCol, MaxDay + 1, (.Rows) * (.Cols - 1), True, msfGrid
            mCurDay = mSelDate ' Day(Date)
            If mCurDay > MaxDay Then
                mCurDay = MaxDay
            End If
            Dim myRow As Integer
            Dim myCol As Integer
            myCol = (DayCol + mCurDay) Mod .Cols
            myRow = ((DayCol + mCurDay)  .Cols) + 1
            If myCol = 0 Then
                myCol = 6
                myRow = myRow - 1
            Else
                myCol = myCol - 1
                myRow = myRow
            End If
            If myRow > 0 Then
            If .Redraw Then .Redraw = False
            misRefresh = True
            mOldRow = myRow
            mOldCol = myCol
            .row = myRow
            .col = myCol
'            misRefresh = False
            If Not .Redraw Then .Redraw = True
            End If
        End If
    End With
End Sub
Private Sub setGridText(DayCol As Integer, StartDay As Integer, EndDay As Integer, isEmpty As Boolean, msfGrid As MSFlexGrid)
    Dim I As Integer
    Dim myRow As Integer
    Dim myCol As Integer
    With msfGrid
        For I = StartDay To EndDay
            myCol = (DayCol + I) Mod .Cols
            myRow = ((I + DayCol)  .Cols) + 1
            If myRow > .Rows - 1 Then Exit For
            If myCol = 0 Then
                myCol = 6
                myRow = myRow - 1
            Else
                myCol = myCol - 1
                myRow = myRow
            End If
            Dim tmpStr As String
            If isEmpty Then
                tmpStr = Empty
            Else
                tmpStr = I
            End If
            .TextArray(faIndex(myRow, myCol)) = tmpStr
        Next
    End With
End Sub
Private Sub msfGrid_DblClick()
    Command1_Click
End Sub
Private Sub msfGrid_EnterCell()
    With msfGrid
        .CellBackColor = vbBlue
        .CellForeColor = vbWhite
    End With
End Sub
Private Sub msfGrid_GotFocus()
    misToCheckMouse = True
End Sub
Private Sub msfGrid_LeaveCell()
    With msfGrid
        .CellBackColor = vbWhite
        .CellForeColor = vbBlack
    End With
End Sub
Private Sub msfGrid_LostFocus()
    misToCheckMouse = False
    With msfGrid
        mOldRow = .row
        mOldCol = .col
    End With
    misRefresh = False
End Sub
Private Sub msfGrid_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    With msfGrid
        .row = .row
        .col = .col
        .RowSel = .row
        .ColSel = .col
    End With
End Sub
Private Sub msfGrid_SelChange()
    With msfGrid
        Dim myRow As Integer
        Dim myCol As Integer
        If Trim(.TextMatrix(.row, .col)) = Empty Then
            'If .Redraw Then .Redraw = False
            .row = mOldRow
            .col = mOldCol
            If .Redraw Then .Redraw = False
        Else
            'If Not .Redraw Then .Redraw = True
            mSelDate = Val(.TextMatrix(.row, .col))
        End If
        If misToCheckMouse Then
            myRow = .MouseRow
            myCol = .MouseCol
        Else
            If Not misRefresh Then
                myRow = mOldRow
                myCol = mOldCol
                .row = mOldRow
                .col = mOldCol
            Else
                myRow = .row
                myCol = .col
            End If
        End If
            If myRow = 0 Then 'Or Trim(.TextMatrix(myRow, myCol)) = Empty Then 'If .MouseRow = 0 Or Trim(.TextMatrix(.MouseRow, .MouseCol)) = Empty Then
                .row = mOldRow
                .col = mOldCol
                If .Redraw Then .Redraw = False
            Else
                mOldRow = .row
                mOldCol = .col
                If Not .Redraw Then .Redraw = True
            End If
    End With
End Sub
Private Sub txtMonth_Change()
   If Trim(txtMonth) = Empty Then Exit Sub
'    VScrollMonth.Value = Val(txtMonth.Text)
    If Not misStart Then
        RefreshDayList
    End If
End Sub
Private Sub txtMonth_GotFocus()
    GotFocus txtMonth
End Sub
Private Sub txtMonth_KeyDown(KeyCode As Integer, Shift As Integer)
    With VScrollMonth
        Select Case KeyCode
            Case 13
                If (Val(txtMonth) >= .Min) And (Val(txtMonth) <= .Max) Then
                    SendKeyTab KeyCode
                End If
            Case vbKeyUp
                If Val(txtMonth) < .Max Then txtMonth = Val(txtMonth) + 1
            Case vbKeyDown
                If Val(txtMonth) > .Min Then txtMonth = Val(txtMonth) - 1
        End Select
    End With
End Sub
Private Sub txtMonth_KeyPress(KeyAscii As Integer)
    KeyAscii = ValiText(KeyAscii, "123456789", True)
End Sub
Private Sub txtYear_Change()
    If Len(Trim(txtYear)) < 4 Then Exit Sub
'    VScrollYear.Value = Val(txtYear.Text)
    If Not misStart Then
        RefreshDayList
    End If
End Sub
Private Sub txtYear_GotFocus()
    GotFocus txtYear
End Sub
Private Sub txtYear_KeyDown(KeyCode As Integer, Shift As Integer)
    With VScrollYear
        Select Case KeyCode
            Case 13
                If (Val(txtYear) >= .Min) And (Val(txtYear) <= .Max) Then
                    SendKeyTab KeyCode
                End If
            Case vbKeyUp
                If Val(txtYear) < .Max Then txtYear = Val(txtYear) + 1
            Case vbKeyDown
                If Val(txtYear) > .Min Then txtYear = Val(txtYear) - 1
        End Select
    End With
End Sub
Private Sub txtYear_KeyPress(KeyAscii As Integer)
    KeyAscii = ValiText(KeyAscii, "0123456789", True)
End Sub
Private Sub VScrollMonth_Change()
'    txtMonth = VScrollMonth.Value
End Sub
Private Sub VScrollYear_Change()
'    txtYear = VScrollYear.Value
End Sub
Function faIndex(row As Integer, col As Integer) As Long
     faIndex = row * msfGrid.Cols + col
End Function

						