unit uMainTestCalLite; {$mode objfpc}{$H+} interface uses Classes, SysUtils, Forms, Graphics, ExtCtrls, StdCtrls, Spin, Dialogs, Controls, Menus, Buttons, CalendarLite, LCLVersion; type { TForm1 } TForm1 = class(TForm) BtnFont: TButton; cbUseHolidays: TCheckBox; cgOptions: TCheckGroup; CbArrowBorder: TColorButton; CbTodayFrame: TColorButton; CbTopRow: TColorButton; CbTopRowText: TColorButton; CbWeekend: TColorButton; CbArrow: TColorButton; CbBackground: TColorButton; CbBorder: TColorButton; CbDayLine: TColorButton; CbHolidays: TColorButton; CbPastMonth: TColorButton; CbSelectedDate: TColorButton; CbText: TColorButton; CbPrepareCanvas: TCheckBox; CbDrawCell: TCheckBox; CbAddHolidayNameToCell: TCheckBox; CbShowHints: TCheckBox; CbMultiSelect: TCheckBox; CbUseBuiltinPopup: TCheckBox; FontDialog: TFontDialog; GroupBox1: TGroupBox; ImageList1: TImageList; Label1: TLabel; Label10: TLabel; Label11: TLabel; Label12: TLabel; Label13: TLabel; Label14: TLabel; Label2: TLabel; Label3: TLabel; Label4: TLabel; Label5: TLabel; Label6: TLabel; Label7: TLabel; Label8: TLabel; Label9: TLabel; lHeight1: TLabel; LWidth1: TLabel; MenuItem1: TMenuItem; MenuItem2: TMenuItem; MenuItem3: TMenuItem; PopupMenu1: TPopupMenu; seButtonHeight: TSpinEdit; SelDateListbox: TListBox; LTitle: TLabel; LWidth: TLabel; lHeight: TLabel; PSettings: TPanel; rgLanguage: TRadioGroup; rgStartingDOW: TRadioGroup; seWidth: TSpinEdit; seHeight: TSpinEdit; seButtonWidth: TSpinEdit; sbResetButtonWidth: TSpeedButton; sbResetButtonHeight: TSpeedButton; procedure BtnFontClick(Sender: TObject); procedure CbAddHolidayNameToCellChange(Sender: TObject); procedure CbDrawCellChange(Sender: TObject); procedure CbMultiSelectChange(Sender: TObject); procedure CbPrepareCanvasChange(Sender: TObject); procedure CbShowHintsChange(Sender: TObject); procedure CbUseBuiltinPopupChange(Sender: TObject); procedure ColorButtonChanged(Sender: TObject); procedure cbUseHolidaysChange(Sender: TObject); procedure cgOptionsItemClick(Sender: TObject; Index: integer); procedure FormCreate(Sender: TObject); procedure rgLanguageClick(Sender: TObject); procedure rgStartingDOWClick(Sender: TObject); procedure sbResetButtonHeightClick(Sender: TObject); procedure seButtonHeightChange(Sender: TObject); procedure seHeightChange(Sender: TObject); procedure seButtonWidthChange(Sender: TObject); procedure seWidthChange(Sender: TObject); procedure sbResetButtonWidthClick(Sender: TObject); private copyCal, demoCal: TCalendarLite; FNoHolidays: boolean; procedure RespondToDateChange(Sender: TObject); procedure RespondToMonthChange(Sender: TObject); procedure GetDayText(Sender: TObject; AYear, AMonth, ADay: Word; var AText: String); procedure GetHintText(Sender: TObject; AYear, AMonth, ADay: Word; var AText: String); procedure GetHolidays(Sender: TObject; AMonth, AYear: Integer; // wp var Holidays: THolidays); procedure PrepareCanvas(Sender: TObject; ACanvas: TCanvas; AYear, AMonth, ADay: Word; AState: TCalCellStates); procedure DrawCell(Sender: TObject; ACanvas: TCanvas; AYear, AMonth, ADay: Word; AState: TCalCellStates; var ARect: TRect; var AContinueDrawing: Boolean); end; var Form1: TForm1; implementation {$R *.lfm} uses DateUtils; function Easter(year:integer) : TDateTime; // wp var Day, Month : integer; a,b,c,d,e,m,n : integer; begin case Year div 100 of 17 : begin m := 23; n := 3; end; 18 : begin m := 23; n := 4; end; 19,20 : begin m := 24; n := 5; end; 21 : begin m := 24; n := 6; end; else raise Exception.Create('Only years after 1700 supported.'); end; a := Year mod 19; b := Year mod 4; c := Year mod 7; d := (19*a + m) mod 30; e := (2*b + 4*c + 6*d + n) mod 7; day := 22 + d + e; Month := 3; if Day>31 then begin Day := d + e - 9; Month := 4; if (d=28) and (e=6) and (a>10) then begin if day=26 then day := 19; if day=25 then day := 18; end; end; result := EncodeDate(year, month, day); end; procedure TForm1.FormCreate(Sender: TObject); var opt: TCalOption; begin demoCal := TCalendarLite.Create(Self); demoCal.Parent := Self; demoCal.Left := 10; demoCal.Top := PSettings.Height + 10; demoCal.Width := seWidth.Value; demoCal.Height := seHeight.Value; demoCal.DayNames := 'SUN,MON,TUE,WED,THU,FRI,SAT'; demoCal.MonthNames := 'JAN,FEB,MAR,APR,MAY,JUN,JUL,AUG,SEP,OCT,NOV,DEC'; demoCal.DisplayTexts := 'TODAY: %s,d.m.yy,HOLIDAYS %d,NO HOLIDAYS SET UP IN %d,"dddd d.m.yyyy",mmmm yy'; demoCal.OnGetHolidays := @GetHolidays; demoCal.OnDateChange:= @RespondToDateChange; demoCal.OnMonthChange := @RespondToMonthChange; demoCal.OnHint := @GetHintText; demoCal.ShowHint := true; demoCal.Hint := 'Calendar'; if CbPrepareCanvas.Checked then demoCal.OnPrepareCanvas := @PrepareCanvas else demoCal.OnPrepareCanvas := nil; if CbDrawCell.Checked then demoCal.OnDrawCell := @DrawCell else demoCal.OnDrawCell := nil; FNoHolidays := False; for opt in demoCal.Options do if (opt in demoCal.Options) then cgOptions.Checked[integer(opt)] := True; seHeight.Value := demoCal.Height; seWidth.Value := demoCal.Width; rgStartingDOW.ItemIndex := ord(demoCal.StartingDayOfWeek); copyCal:= TCalendarLite.Create(Self); copyCal.Parent := Self; copyCal.Width := 270; copyCal.Height := 205; copyCal.Left := Width - copyCal.Width; copyCal.Top := Height - copyCal.Height; copyCal.Font.Name := 'Lucida Calligraphy'; copyCal.Colors.SelectedDateColor := clYellow; copyCal.Colors.ArrowBorderColor := clYellow; copyCal.Colors.ArrowColor := clYellow; copyCal.Colors.TodayFrameColor := clWhite; copyCal.Colors.BackgroundColor:= clGradientActiveCaption; copyCal.StartingDayOfWeek:= dowSaturday; copyCal.OnGetHolidays := @GetHolidays; copyCal.Options := copyCal.Options + [coShowBorder,coUseTopRowColors,coDayLine]; CbArrowBorder.ButtonColor := demoCal.Colors.ArrowBorderColor; CbArrow.ButtonColor := demoCal.Colors.ArrowColor; CbBackground.ButtonColor := demoCal.Colors.BackgroundColor; CbBorder.ButtonColor := demoCal.Colors.BorderColor; CbDayLine.ButtonColor := demoCal.Colors.DayLineColor; CbHolidays.Buttoncolor := demoCal.colors.HolidayColor; CbPastMonth.ButtonColor := demoCal.Colors.PastMonthColor; CbSelectedDate.ButtonColor := demoCal.Colors.SelectedDateColor; CbText.ButtonColor := demoCal.Colors.TextColor; CbTodayFrame.ButtonColor := demoCal.Colors.TodayFrameColor; CbTopRow.ButtonColor := demoCal.Colors.TopRowColor; CbTopRowText.ButtonColor := democal.Colors.TopRowTextColor; CbWeekend.ButtonColor := demoCal.Colors.WeekendColor; end; procedure TForm1.rgLanguageClick(Sender: TObject); begin demoCal.Languages := TLanguage(rgLanguage.ItemIndex); copyCal.Languages := demoCal.Languages; exit; if demoCal.Languages = lgCustom then begin demoCal.DayNames := 'S,M,T,W,T,F,S'; demoCal.MonthNames := 'Ja,Fe,Mr,Ap,Ma,Jn,Jl,Au,Sp,Oc,Nv,Dc'; demoCal.DisplayTexts := 'Today,"mmm yyyy",Holidays,"No holidays in"'; end; end; procedure TForm1.rgStartingDOWClick(Sender: TObject); begin demoCal.StartingDayOfWeek := TDayOfWeek(rgStartingDOW.ItemIndex); end; procedure TForm1.sbResetButtonHeightClick(Sender: TObject); begin demoCal.ButtonHeight := 0; seButtonHeight.OnChange := nil; seButtonHeight.Value := 10; seButtonHeight.OnChange := @seButtonHeightChange; end; procedure TForm1.seButtonHeightChange(Sender: TObject); begin demoCal.ButtonHeight := seButtonHeight.Value; end; procedure TForm1.seHeightChange(Sender: TObject); begin demoCal.Height := seHeight.Value; end; procedure TForm1.seButtonWidthChange(Sender: TObject); begin demoCal.ButtonWidth := seButtonWidth.Value; end; procedure TForm1.seWidthChange(Sender: TObject); begin demoCal.Width := seWidth.Value; end; procedure TForm1.sbResetButtonWidthClick(Sender: TObject); begin demoCal.ButtonWidth := 0; seButtonWidth.OnChange := nil; seButtonWidth.Value := 10; seButtonWidth.OnChange := @seButtonWidthChange; end; procedure TForm1.ColorButtonChanged(Sender: TObject); var calendar: TCalendarLite; col: TColor; begin calendar := demoCal; col := (Sender as TColorButton).ButtonColor; case (Sender as TColorButton).Name of 'CbArrowBorder': calendar.Colors.ArrowBorderColor := col; 'CbArrow': calendar.Colors.ArrowColor := col; 'CbBackground': calendar.Colors.BackgroundColor := col; 'CbBorder': calendar.Colors.BorderColor := col; 'CbDayLine': calendar.Colors.DayLineColor := col; 'CbHolidays': calendar.Colors.HolidayColor := col; 'CbPastMonth': calendar.Colors.PastMonthColor := col; 'CbSelectedDate': calendar.Colors.SelectedDateColor := col; 'CbText': calendar.Colors.TextColor := col; 'CbTodayFrame': calendar.Colors.TodayFrameColor := col; 'CbTopRow': calendar.Colors.TopRowColor := col; 'CbTopRowText': calendar.Colors.TopRowTextColor := col; 'CbWeekend': calendar.Colors.WeekendColor := col; end; calendar.Invalidate; end; procedure TForm1.cbUseHolidaysChange(Sender: TObject); begin FNoHolidays := not FNoHolidays; end; procedure TForm1.cgOptionsItemClick(Sender: TObject; Index: integer); var opt: TCalOption; begin opt := TCalOption(Index); if (opt in demoCal.Options) then demoCal.Options := demoCal.Options - [opt] else demoCal.Options := demoCal.Options + [opt]; copyCal.Options := demoCal.Options; end; procedure TForm1.CbUseBuiltinPopupChange(Sender: TObject); begin if CbUseBuiltinPopup.Checked then demoCal.PopupMenu := nil else demoCal.PopupMenu := PopupMenu1; end; procedure TForm1.CbAddHolidayNameToCellChange(Sender: TObject); begin if CbAddHolidayNameToCell.Checked then demoCal.OnGetDayText := @GetDayText else demoCal.OnGetDayText := nil; demoCal.Invalidate; end; procedure TForm1.BtnFontClick(Sender: TObject); begin FontDialog.Font.Assign(demoCal.Font); if FontDialog.Execute then demoCal.Font.Assign(FontDialog.Font); end; procedure TForm1.CbDrawCellChange(Sender: TObject); begin if CbDrawCell.Checked then demoCal.OnDrawCell := @DrawCell else demoCal.OnDrawCell := nil; demoCal.Invalidate; end; procedure TForm1.CbMultiSelectChange(Sender: TObject); begin demoCal.MultiSelect := CbMultiSelect.Checked; end; procedure TForm1.CbPrepareCanvasChange(Sender: TObject); begin if CbPrepareCanvas.Checked then demoCal.OnPrepareCanvas := @PrepareCanvas else demoCal.OnPrepareCanvas := nil; demoCal.Invalidate; end; procedure TForm1.CbShowHintsChange(Sender: TObject); begin demoCal.ShowHint := CbShowHints.Checked; end; procedure TForm1.RespondToDateChange(Sender: tObject); var s: TCalDateArray; i: Integer; begin copyCal.Date:= TCalendarLite(Sender).Date; s := demoCal.SelectedDates; SelDateListbox.Clear; for i:=0 to High(s) do SelDateListbox.Items.Add(DateToStr(s[i])); end; procedure TForm1.RespondToMonthChange(Sender: TObject); begin Label1.Caption := 'Month changed to ' + demoCal.GetMonthName(MonthOf(democal.Date)); end; procedure TForm1.GetDayText(Sender: TObject; AYear, AMonth, ADay: Word; var AText: String); var s: String; begin GetHintText(Sender, AYear, AMonth, ADay, s); if s <> '' then AText := IntToStr(ADay) + LineEnding + s; end; procedure TForm1.GetHintText(Sender: TObject; AYear, AMonth, ADay: Word; var AText: String); var dt, e: TDate; begin AText := ''; case AMonth of 1: if ADay = 1 then AText := 'New Year'; 12: if ADay = 25 then AText := 'Christmas'; else e := Easter(AYear); dt := EncodeDate(AYear, AMonth, ADay); if (dt = e) then AText := 'Easter' else if (dt = e + 49) then AText := 'Whit Sunday'; end; end; procedure TForm1.GetHolidays(Sender: TObject; AMonth, AYear: Integer; var Holidays: THolidays); var d, m, y: Word; e: TDate; begin ClearHolidays(Holidays); if not FNoHolidays then begin // Fixed holidays case AMonth of 1: AddHoliday(1, Holidays); // New Year 12: AddHoliday(25, Holidays); // Christmas end; // Easter e := Easter(AYear); DecodeDate(e, y,m,d); if m = AMonth then AddHoliday(d, Holidays); // Whit Sunday --> 49 days after easter DecodeDate(e+49, y,m,d); if m = AMonth then AddHoliday(d, Holidays); end; end; procedure TForm1.PrepareCanvas(Sender: TObject; ACanvas: TCanvas; AYear,AMonth,ADay: word; AState: TCalCellStates); begin if (ADay = 1) and not (csOtherMonth in AState) then begin ACanvas.Font.Size := 12; ACanvas.Font.Style := [fsUnderline, fsItalic, fsBold]; ACanvas.Font.Color := clGreen; ACanvas.Brush.Color := clSilver; ACanvas.Brush.Style := bsFDiagonal; ACanvas.Pen.Color := clSilver; ACanvas.Pen.Style := psSolid; end; end; procedure TForm1.DrawCell(Sender: TObject; ACanvas: TCanvas; AYear,AMonth,ADay: Word; AState: TCalCellStates; var ARect: TRect; var AContinueDrawing: Boolean); var bmp: TBitmap; begin if (AMonth = 11) and (ADay = 11) and not (csOtherMonth in AState) then begin bmp := TBitmap.Create; try ImageList1.GetBitmap(0, bmp); ACanvas.Draw(ARect.Left, (ARect.Top + ARect.Bottom - bmp.Height) div 2, bmp); inc(ARect.Left, bmp.Width + 2); finally bmp.Free; end; end; end; end.