Programming Tool Box/SIMS_2.iso/tool/various/kalend/test5.frm

Text File | 1995-02-27 | 5KB | 185 lines

VERSION 2.00
Begin Form Form5
   BackColor       =   &H00C0C0C0&
   BorderStyle     =   3  'Fixed Double
   Caption         =   "Schedule Kalendar"
   ClientHeight    =   4230
   ClientLeft      =   3225
   ClientTop       =   630
   ClientWidth     =   6030
   ForeColor       =   &H00000000&
   Height          =   5160
   Left            =   3165
   LinkTopic       =   "Form5"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   4230
   ScaleWidth      =   6030
   Top             =   -240
   Width           =   6150
   Begin Kalendar Kalendar1
      BackColor       =   &H00FFFFFF&
      BorderStyle     =   0  'None
      DateDispStyle   =   2  'User
      DayAlignment    =   0  'Upper Left
      DOWAlign        =   2  'Center
      DOWBackColor    =   &H00008000&
      DOWBorder       =   -1  'True
      DOWDispStyle    =   2  'Medium
      DOWFontBold     =   -1  'True
      DOWFontItalic   =   0   'False
      DOWFontName     =   "Arial"
      DOWFontSize     =   10
      DOWFontStrikeThru=   0   'False
      DOWFontUnderline=   0   'False
      DOWForeColor    =   &H00FFFFFF&
      EnableKeys      =   -1  'True
      FirstDOW        =   0  'Sunday
      FixedDayHeight  =   0   'False
      FontBold        =   -1  'True
      FontItalic      =   -1  'True
      FontName        =   "Arial"
      FontSize        =   12
      FontStrikethru  =   0   'False
      FontUnderline   =   0   'False
      ForeColor       =   &H00000000&
      Height          =   4230
      Left            =   30
      LineColor       =   &H00000000&
      MonAlign        =   2  'Center
      MonBackColor    =   &H00FFFFFF&
      MonDispStyle    =   2  'Month/Year
      MonFontBold     =   0   'False
      MonFontItalic   =   0   'False
      MonFontName     =   "Times New Roman"
      MonFontSize     =   14
      MonFontStrikeThru=   0   'False
      MonFontUnderline=   0   'False
      MonForeColor    =   &H00000000&
      OtherMonBackColor=   &H00FFFFFF&
      OtherMonForeColor=   &H00C0C0C0&
      SelDayBackColor =   &H00FF00FF&
      SelDayForeColor =   &H0000FFFF&
      ShowAllDays     =   -1  'True
      ShowArrows      =   -1  'True
      ShowLines       =   -1  'True
      ShowSelection   =   -1  'True
      TabIndex        =   0
      Text            =   "07/02/94"
      Top             =   0
      Width           =   6000
   End
   Begin Menu mnuFile
      Caption         =   "File"
      Begin Menu mnuFPrint
         Caption         =   "Print &Portrait"
      End
      Begin Menu mnuFPrintLand
         Caption         =   "Print &Landscape"
      End
      Begin Menu mnuFPrint3by3
         Caption         =   "Print 3"" X 3"""
      End
   End
End
Option Explicit

Sub Form_Activate ()
    SetDescription Sample5Description()
End Sub

Sub Form_Load ()
    Kalendar1.Text = Date
End Sub

Sub Form_Resize ()
    Kalendar1.Move 0, 0, Form5.ScaleWidth, Form5.ScaleHeight
End Sub

Sub Kalendar1_ClickDay ()
Dim info As DateRange
    If GetDateRangeInfo((Kalendar1.Julian), info) Then
        Form5.Caption = info.Description
    Else
        Form5.Caption = ""
    End If
End Sub

Sub Kalendar1_DrawOnDay (hdc As Integer, State As Integer, theDay As Long, x As Single, y As Single, x2 As Single, y2 As Single)
Dim info As DateRange
Dim r As Rect
Dim retval As Variant
Dim oldHBrush As Integer, hBrush As Integer, oldPen As Integer

    If GetDateRangeInfo(theDay, info) Then

        KalWindowAPIRect x, y, x2, y2, r

        If info.StartDate = theDay Then
            r.left = r.left + 20
        End If
        If info.EndDate = theDay Then
            r.right = r.right - 20
        End If

        hBrush = CreateSolidBrush(info.color)
        oldHBrush = SelectObject(hdc, hBrush)
        oldPen = SelectObject(hdc, GetStockObject(NULL_PEN))

        r.top = r.bottom - 8
        r.bottom = r.bottom - 2
        retval = Rectangle(hdc, r.left, r.top, r.right, r.bottom)

        retval = SelectObject(hdc, oldPen)
        retval = SelectObject(hdc, oldHBrush)
        retval = DeleteObject(hBrush)
    End If
End Sub

Sub mnuFPrint_Click ()
    Kalendar1.PrintAction = KAL_PRINT_PORTRAIT
End Sub

Sub mnuFPrint3by3_Click ()
Dim SaveMonFontSize As Single
Dim saveBackColor As Long

    SaveMonFontSize = Kalendar1.MonFontSize
    saveBackColor = Kalendar1.MonBackColor

    Kalendar1.MonFontSize = 14
    Kalendar1.MonFontBold = True
    Kalendar1.BorderStyle = 1
    Kalendar1.MonBackColor = RGB(255, 255, 255)

    Kalendar1.PrintX = 2880
    Kalendar1.PrintY = 2880
    Kalendar1.PrintWidth = 1440 * 3
    Kalendar1.PrintHeight = 1440 * 3
    Kalendar1.PrintHDC = Printer.hdc

    Printer.Print   ' Necessary for VB to send STARTDOC, before printing the Kalendar.
    Kalendar1.PrintAction = KAL_PRINT_USER

    Kalendar1.MonFontBold = False
    Kalendar1.MonFontSize = SaveMonFontSize
    Kalendar1.MonBackColor = saveBackColor
    Kalendar1.BorderStyle = 0

    Printer.EndDoc
End Sub

Sub mnuFPrintLand_Click ()
    Kalendar1.PrintAction = KAL_PRINT_LANDSCAPE
End Sub

Function Sample5Description () As String
Dim s As String

    s = "One more example of the DrawOnDay event." & CR
    s = s & "You can also print this Kalendar using the three different methods available."

    Sample5Description = s
End Function