a4e0e87fd5
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@5374 8e941d3f-bd1b-0410-a28a-d453659cc2b4
418 lines
12 KiB
ObjectPascal
418 lines
12 KiB
ObjectPascal
unit uMainTestCalLite;
|
|
|
|
{$mode objfpc}{$H+}
|
|
|
|
interface
|
|
|
|
uses
|
|
Classes, SysUtils, Forms, Graphics, ExtCtrls, StdCtrls, Spin, Dialogs,
|
|
Controls, Menus, CalendarLite;
|
|
|
|
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;
|
|
MenuItem1: TMenuItem;
|
|
MenuItem2: TMenuItem;
|
|
MenuItem3: TMenuItem;
|
|
PopupMenu1: TPopupMenu;
|
|
SelDateListbox: TListBox;
|
|
LTitle: TLabel;
|
|
LWidth: TLabel;
|
|
lHeight: TLabel;
|
|
PSettings: TPanel;
|
|
rgLanguage: TRadioGroup;
|
|
rgStartingDOW: TRadioGroup;
|
|
seWidth: TSpinEdit;
|
|
seHeight: TSpinEdit;
|
|
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 seHeightChange(Sender: TObject);
|
|
procedure seWidthChange(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.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 := integer(demoCal.StartingDayOfWeek)-1;
|
|
|
|
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;
|
|
end;
|
|
|
|
procedure TForm1.rgStartingDOWClick(Sender: TObject);
|
|
begin
|
|
demoCal.StartingDayOfWeek := TDayOfWeek(rgStartingDOW.ItemIndex + 1);
|
|
end;
|
|
|
|
procedure TForm1.seHeightChange(Sender: TObject);
|
|
begin
|
|
demoCal.Height := seHeight.Value;
|
|
end;
|
|
|
|
procedure TForm1.seWidthChange(Sender: TObject);
|
|
begin
|
|
demoCal.Width := seWidth.Value;
|
|
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.
|
|
|