CalLite: Add event OnPrepareCanvas to override day formatting.

git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@5321 8e941d3f-bd1b-0410-a28a-d453659cc2b4

components/callite/demo2/umaintestcallite.lfm

@@ -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

components/callite/demo2/umaintestcallite.pp

@@ -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.
 

components/callite/source/calendarlite.pas

@@ -100,8 +100,11 @@ type
   TGetHolidaysEvent = procedure (Sender: TObject; AMonth, AYear: Integer;
     var Holidays: THolidays) of object;
 
-  TFormatEvent = procedure (Sender: TObject; ADate: TDate;
+  TCalPrepareCanvasState = (pcsSelectedDay, pcsToday, pcsOtherMonth);
-    AFont: TFont; ABkColor: TColor) of object;
+  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:
+      { Default canvas }
-          begin
+      FCanvas.Brush.Style := bsSolid;
-            FCanvas.Font.Color:= FOwner.Colors.PastMonthColor;
+      FCanvas.Brush.Color := FOwner.Colors.BackgroundColor;
-            FCanvas.Font.Style := [];
+      FCanvas.Pen.Style := psClear;
-          end;
+      FCanvas.Pen.Width := 1;
-        True:
+      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 else
-      end;
-      s := IntToStr(d);
-      if (dt = FOwner.FDate) then
       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);
+        Include(state, pcsSelectedDay);
-      end
+      end else
-      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.Pen.Style := psSolid;
-        FCanvas.Frame(rec);
+        Include(state, pcsToday);
-        FCanvas.Pen.Width:= 1;
+      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;