Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/calendei/start2.frm

Visual Basic Form | 1995-05-07 | 8.3 KB | 262 lines

VERSION 2.00
Begin Form Form1
   BackColor       =   &H00C0C0C0&
   BorderStyle     =   1  'Fixed Single
   Caption         =   "Calendar Form"
   ClientHeight    =   3000
   ClientLeft      =   435
   ClientTop       =   2145
   ClientWidth     =   5190
   ControlBox      =   0   'False
   Height          =   3405
   Left            =   375
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   3000
   ScaleWidth      =   5190
   Top             =   1800
   Width           =   5310
   Begin CommandButton Command1
      Caption         =   "Draw New Date"
      Height          =   315
      Left            =   3540
      TabIndex        =   5
      Top             =   540
      Width           =   1515
   End
   Begin CommandButton HelpButton
      Caption         =   "&Help"
      Height          =   375
      Left            =   3840
      TabIndex        =   2
      Top             =   2490
      Width           =   915
   End
   Begin CommandButton CancelButton
      Cancel          =   -1  'True
      Caption         =   "&Cancel"
      Height          =   375
      Left            =   3840
      TabIndex        =   4
      Top             =   1680
      Width           =   915
   End
   Begin CommandButton OkButton
      Caption         =   "&OK"
      Default         =   -1  'True
      Height          =   375
      Left            =   3840
      TabIndex        =   3
      Top             =   1080
      Width           =   915
   End
   Begin TextBox CheckDate
      Height          =   315
      Left            =   3540
      MaxLength       =   10
      TabIndex        =   1
      Text            =   "12/30/90"
      Top             =   120
      Width           =   1275
   End
   Begin PictureBox P
      AutoRedraw      =   -1  'True
      BackColor       =   &H0080FFFF&
      FillStyle       =   0  'Solid
      FontBold        =   -1  'True
      FontItalic      =   0   'False
      FontName        =   "Arial"
      FontSize        =   8.25
      FontStrikethru  =   0   'False
      FontUnderline   =   0   'False
      Height          =   2750
      Left            =   180
      ScaleHeight     =   7.913
      ScaleMode       =   0  'User
      ScaleWidth      =   8.339
      TabIndex        =   0
      Top             =   120
      Width           =   3300
   End
'Copyright
 by David F Eisenberg, 1994.
'This code is freeware.
'You are granted unlimited rights to modify or distribute this code for use in your compiled projects.
'You may NOT distribute this source code without this disclaimer.
'No warantees are stated or implied.
Option Explicit
    Dim DayName(7) As String 'stores names of days
    Dim cRow As Integer 'Current Row
    Dim cCol As Integer 'Current Column
    Dim RowData(8, 7) As Double 'Saves Dates for each position if there is a date there.
    Dim TDate As Double 'Saves date selected.
'Notes: The size of the picture box is critical. You may need to adjust the sizes if the
    'marked dates do not display correctly. Change in increments of 1 twip until all spaces display correctly.
    'The picture box as included should display corectly
'Changes you MUST make:
    '1. Verify the date entered in the box and include a change event to triger a new calendar draw
    '2. Create routines for the buttons
'Recomended changes:
    '1. Add a spin button on the text box. You should verify the current date and reflect the changes
        'in the calendar display by clearing the old marked box and going to the next or previous.
        '(I did not include this because you may not have a spin control)
    '2. Remove the Draw New Date button and replace its function. You may wish to respond
        'to keypress commands or the above spin button.
Sub CancelButton_Click ()
    'put your cancel routine here
    End
End Sub
Sub Command1_Click ()
    DrawCal 'Draws the Calendar
End Sub
Sub DrawCal ()
    'Draws the calendar
    Dim it As Integer 'Counter
    Dim iCol As Integer 'column counter for fill
    Dim iRow As Integer ' "
    Dim cDate As Double 'Date to mark
    Erase RowData 'initialize the date data
    P.Cls 'Clear the picture box
    P.DrawWidth = 1
    'The next lines scale the picture box so that the boxes can be accounted for
    P.ScaleWidth = 7.02
    P.ScaleHeight = 8.03
    'Draw the lines
    P.Line (0, 0)-(7, 1.3), &HFFFF00, BF
    For it = 3 To 8
        P.Line (0, it)-(7, it)
    Next it
    For it = 1 To 6
        P.Line (it, 1.4)-(it, 8)
    Next it
        P.Line (0, 0)-(0, 8.03)
        P.Line (7, 0)-(7, 8.03)
    P.Line (0, 1.4)-(7, 1.4)
    P.Line (0, 0)-(7, 0)
    P.DrawWidth = 2
    P.Line (0, 1.3)-(7, 1.3)
    P.Line (0, 2)-(7, 2)
    P.FontBold = True
    P.CurrentY = 1.4
    P.FontName = "Arial"
    P.FontSize = 8.25
    For it = 1 To 7
        PrintPlace (it - .5), DayName(it)
    Next it
    'Draw the arrows
    P.FontBold = True
    P.FontSize = 16.5
    P.CurrentY = .1
    P.FontName = "WingDings"
    PrintPlace .5, "
    PrintPlace 6.5, "
    P.FontName = "Arial"
    TDate = DateValue(CheckDate.Text)
    PrintPlace 3.5, Format$(TDate, "mmmm yyyy")
    cDate = DateValue(Format$(TDate, "mmmm/1/yyyy")) 'Find 1st day of the month
    iCol = Val(Format$(cDate, "w")) 'Find starting column
    iRow = 3
    P.CurrentY = 2#
    P.FontSize = 14
    Do 'Fill the calendar
        PrintPlace iCol - .5, Format$(cDate, "d")
        RowData(iRow, iCol) = cDate
        If cDate = TDate Then
            cRow = iRow
            cCol = iCol
        End If
        iCol = iCol + 1
        If iCol > 7 Then
            iCol = 1
            iRow = iRow + 1
            P.CurrentY = P.CurrentY + 1
        End If
        cDate = cDate + 1
    Loop Until Day(cDate) = 1 'Check if into the next month and stop
    MarkPlace 'mark the test date in the box
End Sub
Sub Form_Load ()
    'initialize daynames for calendar
    DayName(1) = "Sun"
    DayName(2) = "Mon"
    DayName(3) = "Tue"
    DayName(4) = "Wed"
    DayName(5) = "Thu"
    DayName(6) = "Fri"
    DayName(7) = "Sat"
    CheckDate.Text = Format$(Now, "m/d/yyyy")
    DrawCal
End Sub
Sub HelpButton_Click ()
    'call your help routine here
End Sub
Sub MarkPlace ()
    P.DrawMode = 7 'XOR
        P.Line (cCol - .93, cRow - .9)-(cCol - .04, cRow - .04), QBColor(14), BF
    P.DrawMode = 13
End Sub
Sub OkButton_Click ()
    'put your save routines here
    End
End Sub
Sub P_MouseDown (button As Integer, Shift As Integer, x As Single, y As Single)
    'The scale properties of the form are set to show x and y as calendar positions.
    Dim r As Integer 'row
    Dim c As Integer 'column
    Dim m As Integer 'month
    Dim yr As Integer 'year
    Dim dy As Integer 'day
    If y <= 1.3 Then
        If x < 1 Then 'check to see if on one of the arrows
            m = Month(TDate)
            yr = Year(TDate)
            dy = Day(TDate)
            m = m - 1
            If m = 0 Then
                m = 12
                yr = yr - 1
            End If
            TDate = DateSerial(yr, m, dy)
            Do Until Day(TDate) = dy
                dy = dy - 1
                TDate = DateSerial(yr, m, dy)
            Loop
            CheckDate.Text = Format$(TDate, "m/d/yyyy")
            DrawCal
        ElseIf x > 6 Then
            m = Month(TDate)
            yr = Year(TDate)
            dy = Day(TDate)
            m = m + 1
            If m > 12 Then
                m = 1
                yr = yr + 1
            End If
            TDate = DateSerial(yr, m, dy)
            Do Until Day(TDate) = dy
                dy = dy - 1
                TDate = DateSerial(yr, m, dy)
            Loop
            CheckDate.Text = Format$(TDate, "m/d/yyyy")
            DrawCal
        End If
        Exit Sub
    End If
    r = Int(y) + 1
    c = Int(x) + 1
    If RowData(r, c) Then
        MarkPlace 'remove previous mark
        cRow = r   'save location of new mark
        cCol = c   '"
        MarkPlace  'Place new mark
        TDate = RowData(r, c) 'get new date
        'print new date
        CheckDate.Text = Format$(TDate, "m/d/yyyy")
    End If
End Sub
Sub PrintPlace (x As Single, s As String)
    P.CurrentX = x - P.TextWidth(s) / 2
    P.Print s;
End Sub