pascal/lazarus-ccr
1
0
Fork 0
Code Issues Releases Activity

CalLite: Add event OnPrepareCanvas to override day formatting.

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@5321 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz
2016-11-06 22:29:40 +00:00
parent 4ac2ecd5ec
commit e36f26bc92
3 changed files with 170 additions and 84 deletions
Download Patch File Download Diff File Expand all files Collapse all files

28
components/callite/demo2/umaintestcallite.lfm
View File

@ -1,7 +1,7 @@
object Form1: TForm1
Left = 687
Left = 700
Height = 845
Top = 88
Top = 122
Width = 753
Caption = 'Examples of the TCalendaLite component'
ClientHeight = 845
@ -429,5 +429,29 @@ object Form1: TForm1
ParentColor = False
end
end
object CbPrepareCanvas: TCheckBox
Left = 560
Height = 19
Top = 168
Width = 144
Caption = 'Override font of 1st day'
OnChange = CbPrepareCanvasChange
TabOrder = 7
end
object BtnFont: TButton
Left = 560
Height = 25
Top = 232
Width = 75
Caption = 'Font...'
OnClick = BtnFontClick
TabOrder = 8
end
end
object FontDialog: TFontDialog
MinFontSize = 0
MaxFontSize = 0
left = 662
top = 232
end
end

44
components/callite/demo2/umaintestcallite.pp
View File

@ -13,6 +13,7 @@ type
{ TForm1 }
TForm1 = class(TForm)
BtnFont: TButton;
cbUseHolidays: TCheckBox;
cgOptions: TCheckGroup;
CbArrowBorder: TColorButton;
@ -28,6 +29,8 @@ type
CbPastMonth: TColorButton;
CbSelectedDate: TColorButton;
CbText: TColorButton;
CbPrepareCanvas: TCheckBox;
FontDialog: TFontDialog;
GroupBox1: TGroupBox;
Label10: TLabel;
Label11: TLabel;
@ -50,6 +53,8 @@ type
rgStartingDOW: TRadioGroup;
seWidth: TSpinEdit;
seHeight: TSpinEdit;
procedure BtnFontClick(Sender: TObject);
procedure CbPrepareCanvasChange(Sender: TObject);
procedure ColorButtonChanged(Sender: TObject);
procedure cbUseHolidaysChange(Sender: TObject);
procedure cgOptionsItemClick(Sender: TObject; Index: integer);
@ -64,6 +69,8 @@ type
procedure RespondToDateChange(Sender: tObject);
procedure GetHolidays(Sender: TObject; AMonth, AYear: Integer; // wp
var Holidays: THolidays);
procedure PrepareCanvas(Sender: TObject; AYear, AMonth, ADay: Word;
AState: TCalPrepareCanvasStates; ACanvas: TCanvas);
end;
var
@ -74,6 +81,8 @@ implementation
{$R *.lfm}
uses
Controls;
function Easter(year:integer) : TDateTime; // wp
var
@ -117,6 +126,9 @@ begin
demoCal.Height := seHeight.Value;
demoCal.OnGetHolidays := @GetHolidays;
demoCal.OnDateChange:= @RespondToDateChange;
if CbPrepareCanvas.Checked then
demoCal.OnPrepareCanvas := @PrepareCanvas else
demoCal.OnPrepareCanvas := nil;
FNoHolidays:= False;
for opt in demoCal.Options do
if (opt in demoCal.Options) then cgOptions.Checked[integer(opt)] := True;
@ -190,7 +202,7 @@ begin
col := (Sender as TColorButton).ButtonColor;
case (Sender as TColorButton).Name of
'CbArrowBorder': calendar.Colors.ArrowBorderColor := col;
'CbArror': calendar.Colors.ArrowColor := col;
'CbArrow': calendar.Colors.ArrowColor := col;
'CbBackground': calendar.Colors.BackgroundColor := col;
'CbBorder': calendar.Colors.BorderColor := col;
'CbDayLine': calendar.Colors.DayLineColor := col;
@ -220,6 +232,21 @@ begin
else demoCal.Options := demoCal.Options + [opt];
end;
procedure TForm1.BtnFontClick(Sender: TObject);
begin
FontDialog.Font.Assign(demoCal.Font);
if FontDialog.Execute then
demoCal.Font.Assign(FontDialog.Font);
end;
procedure TForm1.CbPrepareCanvasChange(Sender: TObject);
begin
if CbPrepareCanvas.Checked then
demoCal.OnPrepareCanvas := @PrepareCanvas else
demoCal.OnPrepareCanvas := nil;
demoCal.Invalidate;
end;
procedure TForm1.RespondToDateChange(Sender: tObject);
begin
copyCal.Date:= TCalendarLite(Sender).Date;
@ -252,5 +279,20 @@ begin
end;
end;
procedure TForm1.PrepareCanvas(Sender: TObject; AYear,AMonth,ADay: word;
AState: TCalPrepareCanvasStates; ACanvas: TCanvas);
begin
if (ADay = 1) and not (pcsOtherMonth 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;
end.

146
components/callite/source/calendarlite.pas
View File

@ -100,8 +100,11 @@ type
TGetHolidaysEvent = procedure (Sender: TObject; AMonth, AYear: Integer;
var Holidays: THolidays) of object;
TFormatEvent = procedure (Sender: TObject; ADate: TDate;
AFont: TFont; ABkColor: TColor) of object;
TCalPrepareCanvasState = (pcsSelectedDay, pcsToday, pcsOtherMonth);
TCalPrepareCanvasStates = set of TCalPrepareCanvasState;
TCalPrepareCanvasEvent = procedure (Sender: TObject; AYear, AMonth, ADay: Word;
AState: TCalPrepareCanvasStates; ACanvas: TCanvas) of object;
TCalOption = (coBoldDayNames, coBoldHolidays, coBoldToday, coBoldTopRow,
coBoldWeekend, coDayLine, coShowBorder, coShowHolidays,
@ -192,6 +195,7 @@ type
FMonthNames: TStringList;
FOnDateChange: TNotifyEvent;
FOnGetHolidays: TGetHolidaysEvent;
FOnPrepareCanvas: TCalPrepareCanvasEvent;
FOptions: TCalOptions;
FPopupMenu: TPopupMenu;
FStartingDayOfWeek: TDayOfWeek;
@ -291,6 +295,7 @@ type
// new event properties
property OnDateChange: TNotifyEvent read FOnDateChange write FOnDateChange;
property OnGetHolidays: TGetHolidaysEvent read FOnGetHolidays write FOnGetHolidays;
property OnPrepareCanvas: TCalPrepareCanvasEvent read FOnPrepareCanvas write FOnPrepareCanvas;
end;
procedure ClearHolidays(var AHolidays: THolidays);
@ -409,7 +414,7 @@ begin
FOwner.DateChange;
FCanvas.Brush.Color := FOwner.Colors.BackgroundColor;
FCanvas.FillRect(FBoundsRect);
Self.Draw;
Draw;
DecodeDate(newDate, y, m, d);
end;
@ -420,8 +425,8 @@ begin
CalcSettings;
DrawTopRow;
DrawDayLabels;
DrawDayCells;
DrawTodayRow;
DrawDayCells; // must be last to avoid resetting the canvas
end;
procedure TCalDrawer.DrawArrow(ARect: TRect; AHead: TArrowhead;
@ -431,6 +436,7 @@ var
d, ox, oy, half: integer;
pts: TArrowPoints;
begin
FCanvas.Pen.Style := psSolid;
if (FCanvas.Brush.Color <> FOwner.Colors.ArrowColor) then
FCanvas.Brush.Color:= FOwner.Colors.ArrowColor;
if (FCanvas.Pen.Color <> FOwner.Colors.ArrowBorderColor) then
@ -498,6 +504,9 @@ var
dow, y, m, d: word;
partWeeks: Integer;
dt, todayDate: TDateTime;
oldBrush: TBrush;
oldPen: TPen;
state: TCalPrepareCanvasStates;
begin
todayDate := Date;
dow := DayOfWeek(FOwner.FDate);
@ -510,30 +519,42 @@ begin
startspan := startRow*7 + startCol - 1;
FStartDate := FOwner.FDate - startSpan;
dt := FStartDate;
oldBrush := TBrush.Create;
oldPen := TPen.Create;
{ Get holidays in current month }
ClearHolidays(holidays);
if Assigned(FOwner.FOnGetHolidays) then
FOwner.FOnGetHolidays(FOwner, FThisMonth, FThisYear, holidays);
for r:= FirstDateRow to LastDateRow do
for c:= Low(FColPositions) to High(FColPositions) do
begin
rec := GetCellAtColRow(c, r);
DecodeDate(dt, y, m, d);
case (m = FThisMonth) of
False:
begin
FCanvas.Font.Color:= FOwner.Colors.PastMonthColor;
FCanvas.Font.Style := [];
end;
True:
{ Default canvas }
FCanvas.Brush.Style := bsSolid;
FCanvas.Brush.Color := FOwner.Colors.BackgroundColor;
FCanvas.Pen.Style := psClear;
FCanvas.Pen.Width := 1;
FCanvas.Font.Assign(FOwner.Font);
state := [];
{ Set font of day cells }
if m = FThisMonth then
begin
{ Default text color of day numbers }
FCanvas.Font.Color:= FOwner.Colors.TextColor;
FCanvas.Font.Style := [];
{ Special case: override holidays }
if (coShowHolidays in FOwner.Options) and IsHoliday(d, holidays) then
begin
FCanvas.Font.Color := FOwner.Colors.HolidayColor;
if coBoldHolidays in FOwner.Options then
FCanvas.Font.Style := [fsBold];
end else
{ Special case: override weekend }
if (coShowWeekend in FOwner.Options) and
(TDayOfWeek(DayOfWeek(dt)) in FOwner.FWeekendDays) then
begin
@ -541,28 +562,64 @@ begin
if coBoldWeekend in FOwner.Options then
FCanvas.Font.Style := [fsBold];
end;
end;
end;
s := IntToStr(d);
if (dt = FOwner.FDate) then
end else
begin
{ color of days from previous and next months }
FCanvas.Font.Color:= FOwner.Colors.PastMonthColor;
Include(state, pcsOtherMonth);
end;
{ Set default background color }
if (dt = FOwner.FDate) then begin
FCanvas.Brush.Color:= FOwner.FColors.SelectedDateColor;
FCanvas.FillRect(rec);
end
else
Include(state, pcsSelectedDay);
end else
FCanvas.Brush.Color:= FOwner.Colors.BackgroundColor;
FCanvas.TextRect(rec, 0, 0, s, FTStyle);
{ Set border pen of "today" cell }
if (dt = todayDate) and (coShowTodayFrame in FOwner.Options) then
begin
FCanvas.Pen.Color := FOwner.Colors.TodayFrameColor;
FCanvas.Pen.Width := 2;
Inc(rec.Top); Inc(rec.Bottom);
FCanvas.Frame(rec);
FCanvas.Pen.Width:= 1;
FCanvas.Pen.Style := psSolid;
Include(state, pcsToday);
end else
FCanvas.Pen.Style := psClear;
{ Override canvas properties }
oldPen.Assign(FCanvas.Pen);
oldBrush.Assign(FCanvas.Brush);
if Assigned(FOwner.FOnPrepareCanvas) then
FOwner.FOnPrepareCanvas(Self, y, m, d, state, FCanvas);
{ Paint the background of the selected date }
if (dt = FOwner.FDate) or
(oldBrush.Color <> FCanvas.Brush.Color) or
(oldBrush.Style <> FCanvas.brush.Style) or
(oldPen.Color <> FCanvas.Pen.Color) or
(oldPen.Style <> FCanvas.Pen.Style) or
(oldPen.Width <> FCanvas.Pen.Width)
then
FCanvas.Rectangle(rec);
{ Paint the frame around the "today" cell }
if (dt = todayDate) and (coShowTodayFrame in FOwner.Options) then
begin
Inc(rec.Top);
Inc(rec.Bottom);
FCanvas.Rectangle(rec);
end;
{ Paint the day number }
s := IntToStr(d);
FCanvas.TextRect(rec, 0, 0, s, FTStyle);
dt:= dt + 1;
end; // for c
oldPen.Free;
oldBrush.Free;
end;
procedure TCalDrawer.DrawDayLabels;
@ -909,51 +966,12 @@ begin
FirstDateRow..LastDateRow :
ChangeDateTo(cell);
else
GotoToday;
end;
end;
(*
procedure TCalDrawer.NextDay;
begin
FOwner.Date := IncDay(FOwner.FDate, 1);
end;
procedure TCalDrawer.NextMonth;
begin
FOwner.Date := IncMonth(FOwner.FDate, 1);
end;
procedure TCalDrawer.NextWeek;
begin
FOwner.Date := IncWeek(FOwner.FDate, 1);
end;
procedure TCalDrawer.NextYear;
begin
FOwner.Date := IncYear(FOwner.FDate, 1);
end;
procedure TCalDrawer.PrevDay;
begin
FOwner.Date := IncDay(FOwner.FDate, -1);
end;
procedure TCalDrawer.PrevMonth;
begin
FOwner.Date := IncMonth(FOwner.FDate, -1);
end;
procedure TCalDrawer.PrevWeek;
begin
FOwner.Date := IncWeek(FOwner.FDate, -1);
end;
procedure TCalDrawer.PrevYear;
begin
FOwner.Date := IncYear(FOwner.FDate, -1);
end;
*)
procedure TCalDrawer.RightClick;
begin
if Assigned(FOwner.FOnGetHolidays) then
@ -1144,6 +1162,7 @@ begin
begin
if ParentColor then
Colors.BackgroundColor := Parent.Color;
if ParentFont then
begin
if (Parent.Font <> FCalDrawer.FCanvas.Font)
@ -1165,6 +1184,7 @@ begin
begin
if (Canvas.Pen.Color <> FColors.BorderColor) then
Canvas.Pen.Color := FColors.BorderColor;
Canvas.Pen.Style := psSolid;
Canvas.Frame(ClientRect);
end;