Programming Tool Box/SIMS_2.iso/code/design/vbcal/calender.frm

Text File | 1993-07-06 | 8KB | 257 lines

VERSION 2.00
Begin Form Calender
   BackColor       =   &H00C0C0C0&
   Caption         =   "Calender"
   ClientHeight    =   5685
   ClientLeft      =   90
   ClientTop       =   375
   ClientWidth     =   6315
   Height          =   6090
   Left            =   30
   LinkTopic       =   "Form1"
   ScaleHeight     =   5685
   ScaleWidth      =   6315
   Top             =   30
   Width           =   6435
   Begin SSPanel Panel3D3
      AutoSize        =   3  'AutoSize Child To Panel
      BackColor       =   &H00C0C0C0&
      BevelOuter      =   1  'Inset
      BorderWidth     =   8
      Font3D          =   0  'None
      Height          =   255
      Left            =   3480
      TabIndex        =   0
      Top             =   4680
      Width           =   1695
      Begin Label DateField
         BackColor       =   &H00C0C0C0&
         Height          =   225
         Left            =   15
         TabIndex        =   8
         Top             =   15
         Width           =   1665
      End
   End
   Begin SSCommand GetDate
      Caption         =   "Pick a date"
      Font3D          =   3  'Inset w/light shading
      Height          =   555
      Left            =   1200
      TabIndex        =   7
      Top             =   4500
      Width           =   1455
   End
   Begin SSPanel CalenderForm
      Alignment       =   8  'Center - BOTTOM
      BackColor       =   &H00C0C0C0&
      BevelOuter      =   1  'Inset
      BorderWidth     =   8
      Caption         =   "Double click on a date to select"
      Font3D          =   1  'Raised w/light shading
      Height          =   2835
      Left            =   960
      TabIndex        =   1
      Top             =   660
      Visible         =   0   'False
      Width           =   4215
      Begin SSPanel Panel3D1
         Alignment       =   8  'Center - BOTTOM
         AutoSize        =   3  'AutoSize Child To Panel
         BackColor       =   &H00C0C0C0&
         BevelOuter      =   1  'Inset
         BorderWidth     =   8
         Font3D          =   1  'Raised w/light shading
         Height          =   255
         Left            =   120
         TabIndex        =   9
         Top             =   60
         Width           =   1455
         Begin Label DateCaption
            BackColor       =   &H00C0C0C0&
            Height          =   225
            Left            =   15
            TabIndex        =   6
            Top             =   15
            Width           =   1425
         End
      End
      Begin SSPanel Panel3D2
         BackColor       =   &H00C0C0C0&
         BevelOuter      =   1  'Inset
         BorderWidth     =   8
         Font3D          =   0  'None
         Height          =   495
         Left            =   120
         TabIndex        =   3
         Top             =   2100
         Width           =   3975
         Begin SSCommand Previous
            Caption         =   "Previous Month"
            Font3D          =   3  'Inset w/light shading
            Height          =   375
            Left            =   240
            TabIndex        =   5
            Top             =   60
            Width           =   1695
         End
         Begin SSCommand Next
            Caption         =   "Next Month"
            Font3D          =   3  'Inset w/light shading
            Height          =   375
            Left            =   2040
            TabIndex        =   4
            Top             =   60
            Width           =   1695
         End
      End
      Begin Grid Calender
         BackColor       =   &H0000FFFF&
         Cols            =   7
         FixedCols       =   0
         Height          =   1695
         Left            =   120
         Rows            =   7
         ScrollBars      =   0  'None
         TabIndex        =   2
         Top             =   360
         Width           =   3975
      End
   End
End
Option Explicit

' Create module global variables
Dim mgiCurrentMonth As Integer
Dim mgiCurrentYear As Integer
Dim mgiCurrentDay As Integer
Dim mgiStartMonth As Integer
Dim mgiStartDay As Integer
Dim mgiStartYear As Integer
Dim mgiStartDOW As Integer ' What day of the week does the 1st fall on
Dim mgiLastDOW As Integer  ' What is the last day of the week
Dim mgsDayNames(0 To 6) As String * 3   ' The names of the days. Change this for different languages
Dim mgsPickDate As String ' This is the global variable used to transfer the date in

Sub Calender_DblClick ()
Dim s As String

    If Calender.Text <> "" And Calender.CellSelected = True Then
        ' Put the date in a module global varible to be picked up elsewhere
        mgsPickDate = Calender.Text + "/" + Str$(mgiCurrentMonth) + "/" + Str$(mgiCurrentYear)
    End If

End Sub

Sub DoCalender (lsStartDate As Variant)
Dim lsStartString As String, liX As Integer, liY As Integer

    ' Find the first day of the week for the month
    mgiStartMonth = Month(lsStartDate)
    mgiCurrentMonth = mgiStartMonth
    mgiStartYear = Year(lsStartDate)
    mgiCurrentYear = mgiStartYear
    mgiCurrentDay = Day(lsStartDate)
    lsStartString = "1/" + Str$(mgiStartMonth) + "/" + Str$(mgiStartYear)
    mgiStartDOW = Weekday(Format$(lsStartString, "dd/mm/yyyy"))
    DateCaption.Caption = Format$(lsStartDate, "mmmm yyyy")

    On Error Resume Next
    For liX = 27 To 32
        lsStartString = Str$(liX) + "/" + Str$(mgiStartMonth) + "/" + Str$(mgiStartYear)
        liY = Weekday(Format$(lsStartString, "dd/mm/yyyy"))
        If Err <> 0 Then
            Err = 0
            Exit For
        End If
    Next liX
    mgiLastDOW = liX - 1

    ' Clear out the calender to remove any previous data
    For liX = 0 To 6
        For liY = 1 To 6
            Calender.Col = liX
            Calender.Row = liY
            Calender.Text = ""
        Next liY
    Next liX

    ' Now fill in the dates
    Calender.Col = mgiStartDOW - 1 ' Weekdays go 1 to 7, cols go 0 to 6
    Calender.Row = 1
    For liX = 1 To mgiLastDOW
        Calender.Text = liX
        liY = Calender.Col + 1
        If liY = 7 Then
            Calender.Col = 0
            Calender.Row = Calender.Row + 1
        Else
            Calender.Col = Calender.Col + 1
        End If
    Next liX


End Sub

Sub Form_Load ()
Dim liX As Integer

    mgsDayNames(0) = "Sun"
    mgsDayNames(1) = "Mon"
    mgsDayNames(2) = "Tue"
    mgsDayNames(3) = "Wed"
    mgsDayNames(4) = "Thu"
    mgsDayNames(5) = "Fri"
    mgsDayNames(6) = "Sat"

    ' Set up the calender days
    Calender.Row = 0
    For liX = 0 To 6
        Calender.Col = liX
        Calender.ColAlignment(liX) = 2
        Calender.Text = mgsDayNames(liX)
    Next liX

End Sub

Sub GetDate_Click ()

    GetDate.Enabled = False
    CalenderForm.Visible = True
    mgsPickDate = ""   ' For this demonstration we just test for the date string being there
    DoCalender Now
    Do While mgsPickDate = ""
        DoEvents
    Loop
    CalenderForm.Visible = False
    DateField.Caption = Format$(mgsPickDate, "dd-mmm-yyyy") ' Display the date
    GetDate.Enabled = True

End Sub

Sub Next_Click ()
Dim ls As String

    mgiCurrentMonth = mgiCurrentMonth + 1
    If mgiCurrentMonth = 13 Then
        mgiCurrentMonth = 1
        mgiCurrentYear = mgiCurrentYear + 1
    End If
    ls = Str$(mgiCurrentDay) + "/" + Str$(mgiCurrentMonth) + "/" + Str$(mgiCurrentYear)
    DoCalender ls

End Sub

Sub Previous_Click ()
Dim ls As String

    mgiCurrentMonth = mgiCurrentMonth - 1
    If mgiCurrentMonth = 0 Then
        mgiCurrentMonth = 12
        mgiCurrentYear = mgiCurrentYear - 1
    End If
    ls = Str$(mgiCurrentDay) + "/" + Str$(mgiCurrentMonth) + "/" + Str$(mgiCurrentYear)
    DoCalender ls
End Sub