Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/dt01/dt01.frm

Visual Basic Form | 1995-09-06 | 15.1 KB | 372 lines

VERSION 2.00
Begin Form frmCalendar
   AutoRedraw      =   -1  'True
   BackColor       =   &H00C0C0C0&
   BorderStyle     =   0  'None
   ClientHeight    =   1020
   ClientLeft      =   1335
   ClientTop       =   1710
   ClientWidth     =   1950
   ForeColor       =   &H00000000&
   Height          =   1425
   Left            =   1275
   ScaleHeight     =   1020
   ScaleWidth      =   1950
   Top             =   1365
   Width           =   2070
   Begin PictureBox gpMonthSpin
      BackColor       =   &H00C0C0C0&
      Height          =   252
      Index           =   2
      Left            =   1320
      ScaleHeight     =   225
      ScaleWidth      =   270
      TabIndex        =   2
      Top             =   120
      Width           =   300
   End
   Begin PictureBox gpMonthSpin
      BackColor       =   &H00C0C0C0&
      Height          =   252
      Index           =   1
      Left            =   360
      ScaleHeight     =   225
      ScaleWidth      =   270
      TabIndex        =   3
      Top             =   120
      Width           =   300
   End
   Begin PictureBox pic
      AutoRedraw      =   -1  'True
      BackColor       =   &H00C0C0C0&
      BorderStyle     =   0  'None
      FontTransparent =   0   'False
      ForeColor       =   &H00000000&
      Height          =   372
      Left            =   480
      ScaleHeight     =   375
      ScaleWidth      =   375
      TabIndex        =   0
      Top             =   480
      Width           =   372
   End
   Begin Timer TmrMonthSpin
      Enabled         =   0   'False
      Interval        =   200
      Left            =   1320
      Top             =   480
   End
   Begin Label lblMonthText
      Alignment       =   2  'Center
      BackColor       =   &H00C0C0C0&
      Caption         =   "lMonth"
      Height          =   192
      Left            =   720
      TabIndex        =   1
      Top             =   120
      Width           =   564
   End
Option Explicit
    ' Create form level globals?
    Dim nCurrentYear As Integer
    Dim nCurrentMonth As Integer
    Dim nCurrentDay As Integer
    Dim nStartDay As Integer
    Dim nTotalDays As Integer
    Dim nBlockNdx As Integer
    Dim nCopyBlockNdx As Integer
    Dim nBlockHeight As Integer
    Dim nWidth As Integer
    Dim nHeight As Integer
Sub Form_Activate ()
    ' Initialize form level date variables.
    ' -------------------------------------
    If IsDate(gDate) Then
        nCurrentYear = Year(gDate)
        nCurrentMonth = Month(gDate)
        nCurrentDay = Day(gDate)
    Else
        nCurrentYear = Year(Now)
        nCurrentMonth = Month(Now)
        nCurrentDay = Day(Now)
    End If
    ' print days of the month.
    ' ------------------------
    PrintMonth
End Sub
'================================================
' = Get all the static non-moving bits out here =
'================================================
Sub Form_Load ()
    Dim i As Integer
    Dim nOldWidth As Integer
    ' Set width/height of one char.
    ' -----------------------------
    nWidth = TextWidth("M") ' Change this for bigger/smaller calendars.
    nHeight = nWidth * 1.9
    ' resize the form.
    ' ----------------
    Me.Height = (nHeight * 6) + (nHeight * .75)
    Me.Width = ((nWidth * 2) * 7) + (nWidth * 1.25)
    ' position left/right arrows.
    ' ---------------------------
    gpMonthSpin(1).Top = nHeight / 4
    gpMonthSpin(2).Top = nHeight / 4
    gpMonthSpin(1).Left = nWidth / 2
    gpMonthSpin(2).Left = Width - gpMonthSpin(1).Width - (nWidth / 2)
    ' position month label between l/r arrows.
    ' ----------------------------------------
    lblMonthText.Top = nHeight / 4
    lblMonthText.Left = gpMonthSpin(1).Left + gpMonthSpin(1).Width
    lblMonthText.Width = gpMonthSpin(2).Left - lblMonthText.Left
    ' size background panel.
    ' ----------------------
    pic.Top = (nHeight * 2.25)
    pic.Left = (nWidth / 2)
    pic.Width = ((nWidth * 2) * 7) + 20
    pic.Height = (nHeight * 4) + 50
    ' Output Day text.
    ' ----------------
    For i = 1 To 7
        CurrentY = nHeight * 1.25
        CurrentX = (i * (nWidth * 2)) - (nWidth * 1.5)
        Print Mid$("SuMoTuWeThFrSa", i * 2 - 1, 2)
    Next
    ' draw separator line + shadow.
    ' -----------------------------
    Line (0, nHeight * 2)-(Width, nHeight * 2), QBColor(0)
    Line (0, nHeight * 2 + (nHeight / 29))-(Width, nHeight * 2 + (nHeight / 29)), QBColor(15)
    ' Attempt at a 3D border.
    ' -----------------------
    nOldWidth = Me.DrawWidth
    Me.DrawWidth = 10
    Me.Line (-30, -30)-Step(Me.Width + 50, 0), QBColor(15)
    Me.Line -Step(0, Me.Height + 40), QBColor(8)
    Me.Line -Step(-(Me.Width + 50), 0), QBColor(8)
    Me.Line -Step(0, -(Me.Height + 40)), QBColor(15)
    Me.DrawWidth = nOldWidth
End Sub
' =============================================================
' Name.........: GetNumDaysInMonth(nYear, nMonth)
' Description..: Computes the number of days in any given month
' Parameters...: <nYear>  - needed to check for leap years
'                <nMonth> - the month number (1-12)
' Returns......: An integer representing the days in the month
' =============================================================
Function GetNumDaysInMonth (nYear As Integer, nMonth As Integer) As Integer
    Dim cMonth As String, nDays As Integer
    cMonth = "312831303130313130313031"
    ' Set defaults.
    ' -------------
    If nYear < 100 Or nYear > 9999 Then nYear = Year(Now)
    If nMonth < 1 Or nMonth > 12 Then nMonth = Month(Now)
    ' Set the number of days in the requested month.
    ' ----------------------------------------------
    nDays = Val(Mid$(cMonth, nMonth * 2 - 2 + 1, 2))
    ' Compensate if requested year is a leap year, and month is February.
    ' -------------------------------------------------------------------
    If IsLeapYear(nYear) And nMonth = 2 Then nDays = nDays + 1
    GetNumDaysInMonth = nDays
End Function
Sub gpMonthSpin_MouseDown (Index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single)
    gpMonthSpin(Index).PictureDnChange = 2
    TmrMonthSpin.Interval = 500
    TmrMonthSpin.Enabled = True
    TmrMonthSpin.Tag = Choose(Index, -1, 1)
    nCurrentMonth = nCurrentMonth + TmrMonthSpin.Tag
    PrintMonthText
End Sub
Sub gpMonthSpin_MouseUp (Index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single)
    gpMonthSpin(Index).PictureDnChange = 0
    ' turn off timer
    TmrMonthSpin.Enabled = False
    PrintMonth
End Sub
' =============================================================
' Name.........: IsLeapYear( nYear )
' Description..:  Determines if a year is a leap year, or not.
' Parameters...: <nYear>  -
' Returns......: An integer (boolean). True = it is a leap year
' =============================================================
Function IsLeapYear (nYear)
   ' If the year is evenly divisible by 4 and not divisible
   ' by 100, or if the year is evenly divisible by 400, then
   ' it's a leap year.
   IsLeapYear = (nYear Mod 4 = 0 And nYear Mod 100 <> 0) Or (nYear Mod 400 = 0)
End Function
Sub pic_Click ()
    ' Return to 'sub-level' code.
    ' ---------------------------
    If nCurrentDay > 0 Then
        gDate = DateSerial(nCurrentYear, nCurrentMonth, nCurrentDay)
        Me.Hide
    End If
End Sub
Sub pic_MouseDown (Button As Integer, Shift As Integer, x As Single, y As Single)
    ' Just pass it along to "MouseMove".
    ' ----------------------------------
    pic_MouseMove Button, Shift, x, y
End Sub
Sub pic_MouseMove (Button As Integer, Shift As Integer, x As Single, y As Single)
    Dim i  As Integer
    Dim xt As Integer, x1 As Integer, x2 As Integer
    Dim yt As Integer, y1 As Integer, y2 As Integer
    ' OK. The mouse is moving over the picture. Do we care?
    ' Only if the left mouse button is pressed.
    ' We then need to find out which part of the picture,
    ' the mouse is over, and change the shadow state.
    If (Button = 1) Then
        For i = 1 To 42

            yt = Int((i - 1) / 7) + 1
            xt = i - (Int((yt - 1) * 7))
            y1 = (yt - 1) * nBlockHeight: y2 = yt * nBlockHeight
            x1 = (xt - 1) * (nWidth * 2): x2 = xt * (nWidth * 2)
            If (x >= x1) And (x <= x2) And (y >= y1) And (y <= y2) Then nBlockNdx = i: Exit For
        Next
        If (nBlockNdx <> nCopyBlockNdx) And (nBlockNdx > 0) And (nBlockNdx - nStartDay <= nTotalDays) And (nBlockNdx - nStartDay > 0) Then

            PrintDay nCopyBlockNdx, 0, 0, 0
            nCopyBlockNdx = nBlockNdx
            nCurrentDay = nBlockNdx - nStartDay
            PrintDay nCopyBlockNdx, 1, 0, 0

        End If
    End If
End Sub
Sub pic_MouseUp (Button As Integer, Shift As Integer, x As Single, y As Single)
    pic_Click
End Sub
' ===============================================================
' Name.........: PrintDay( nDayIndex, lBorder, lBold, nCaption )
' Description..: Draws / Clears the border around a box
' Parameters...: <nDayIndex>  - Number of box to deal with (1-42)
'                <lSetBorder> - True  = draw a 3D border
'                               false = clear the border
' ===============================================================
Sub PrintDay (nCurrBlock, lBorder As Integer, lBold As Integer, nCaption As Integer)
    Dim x As Integer, x1 As Integer, x2 As Integer
    Dim y As Integer, y1 As Integer, y2 As Integer
    Dim cCaption As String
    ReDim aBorderColours(4)

    ' Setup colours for border / no border.
    ' -------------------------------------
    If lBorder Then
        aBorderColours(1) = 0
        aBorderColours(2) = 15
        aBorderColours(3) = 15
        aBorderColours(4) = 0
    Else
        aBorderColours(1) = 7
        aBorderColours(2) = 7
        aBorderColours(3) = 7
        aBorderColours(4) = 7
    End If
    y = Int((nCurrBlock - 1) / 7) + 1
    x = nCurrBlock - (Int((y - 1) * 7))
    y1 = (y - 1) * nBlockHeight: y2 = y * nBlockHeight
    x1 = (x - 1) * (nWidth * 2): x2 = x * (nWidth * 2)

    pic.Line (x1, y1)-(x2, y1), QBColor(aBorderColours(1))
    pic.Line (x2, y1)-(x2, y2), QBColor(aBorderColours(2))
    pic.Line (x2, y2)-(x1, y2), QBColor(aBorderColours(3))
    pic.Line (x1, y2)-(x1, y1), QBColor(aBorderColours(4))
    ' Set Bold/Unbold attribute (only Bold if it's today)
    ' and print caption (only if there is a caption to print!)
    If nCaption > 0 Then

        pic.FontBold = False: pic.ForeColor = QBColor(0)
        If lBold Then pic.FontBold = True: : pic.ForeColor = QBColor(4)
        cCaption = CStr(nCaption)
        pic.CurrentX = x1 + ((x2 - x1) - TextWidth(cCaption)) / 2
        pic.CurrentY = y1 + ((y2 - y1) - TextHeight(cCaption)) / 2
        pic.Print cCaption
    End If
End Sub
' =============================================================
' Name.........: PrintMonth()
' Description..: Output month text & numbers
' Notes........: This is a 'mega-slow' procedure. It's a pity
'                we can't do without it.
' =============================================================
Sub PrintMonth ()
    Static nCopyYear As Integer  ' Saved, so we don't needlessly print the same
    Static nCopyMonth As Integer ' month twice.
    Dim nCount  As Integer
    Dim nWeeks As Integer
    Dim nCaption As Integer
    If (nCurrentYear <> nCopyYear Or nCurrentMonth <> nCopyMonth) Then
        pic.Visible = False
        pic.Cls
        nCopyYear = nCurrentYear: nCopyMonth = nCurrentMonth

        ' ======================================================
        ' First day in a month.
        ' An integer between 1 (Sunday) and 7 (Saturday)
        ' that represents the day of the week for a date argument.
        ' ======================================================
        nStartDay = Weekday(DateSerial(nCurrentYear, nCurrentMonth, 1)) - 1

        ' ======================================================
        ' Total days in a month.
        ' An integer between 1 and ( 28 or 29 or 30 or 31 )
        ' that represents the number of days in a month.
        ' ======================================================
        nTotalDays = GetNumDaysInMonth(nCurrentYear, nCurrentMonth)
        ' ======================================================
        ' Total weeks in a month.
        ' An integer between 4 and 6
        ' that represents the number of weeks in a month.
        ' ======================================================
        nWeeks = Int((nTotalDays + nStartDay) / 7) + Sgn((nTotalDays + nStartDay) Mod 7)

        ' ======================================================
        ' Calculate vertical space needed to display the days
        ' ======================================================
        nBlockHeight = (pic.Height - 50) / nWeeks
        PrintMonthText
        ' ======================================================
        ' Adjust 'Current Day' In case it's .GT. 'total days'
        ' ======================================================
        While nCurrentDay > nTotalDays: nCurrentDay = nCurrentDay - 1: Wend
        nBlockNdx = nCurrentDay + nStartDay
        nCopyBlockNdx = nBlockNdx
        ' ==============================================
        '  Output the month 'Captions'
        ' ==============================================
        For nCount = 1 To nWeeks * 7

            nCaption = IIf((nCount >= nStartDay + 1) And (nCount < nTotalDays + nStartDay + 1), nCount - nStartDay, 0)

            PrintDay nCount, 0, nCurrentYear = Year(Now) And nCurrentMonth = Month(Now) And nCount - nStartDay = Day(Now), nCaption
        Next
        ' ==============================================
        ' Draw the border around selected day.
        ' ==============================================
        PrintDay nCurrentDay + nStartDay, 1, 0, 0
        pic.Visible = True
    End If
End Sub
' =============================================================
' Name.........: PrintMonthText()
' Description..: Output month text
' =============================================================
Sub PrintMonthText ()
    If nCurrentMonth > 12 Then nCurrentMonth = 1: nCurrentYear = nCurrentYear + 1
    If nCurrentMonth < 1 Then nCurrentMonth = 12: nCurrentYear = nCurrentYear - 1
    nCurrentYear = IIf(nCurrentYear > 9999, 9999, nCurrentYear)
    nCurrentYear = IIf(nCurrentYear < 100, 100, nCurrentYear)
    lblMonthText.Caption = Format$(DateSerial(nCurrentYear, nCurrentMonth, 1), "mmmm yyyy")
    Me.Refresh
End Sub
Sub TmrMonthSpin_Timer ()
    ' Speed up the timer, on each call.
    ' ---------------------------------
    TmrMonthSpin.Interval = TmrMonthSpin.Interval * .8
    ' Update the current month, and print text.
    ' ----------------------------------------
    nCurrentMonth = nCurrentMonth + TmrMonthSpin.Tag
    PrintMonthText
End Sub