lazarus-ccr/components/callite/source/calendarlite.pas

{ TCalendarLite is a lightweight calendar component, a TGraphiccontrol
  descendant, which is consequently not dependent on any widgetset.
  It is not a fixed-size component, as are most calendars, but will align
  and resize as needed

  Originator    : H Page-Clark, 2013
  Contributions : Ariel Rodriguez, 2013
                  Werner Pamler, 2013/2016

  This library is free software; you can redistribute it and/or modify it
  under the terms of the GNU Library General Public License as published by
  the Free Software Foundation; either version 2 of the License, or (at your
  option) any later version with the following modification:

  As a special exception, the copyright holders of this library give you
  permission to link this library with independent modules to produce an
  executable, regardless of the license terms of these independent modules,and
  to copy and distribute the resulting executable under terms of your choice,
  provided that you also meet, for each linked independent module, the terms
  and conditions of the license of that module. An independent module is a
  module which is not derived from or based on this library. If you modify
  this library, you may extend this exception to your version of the library,
  but you are not obligated to do so. If you do not wish to do so, delete this
  exception statement from your version.

  This program is distributed in the hope that it will be useful, but WITHOUT
  ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License
  for more details.

  You should have received a copy of the GNU Library General Public License
  along with this library; if not, write to the Free Software Foundation,
  Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
}

unit CalendarLite;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, types,
  menus;

const
  TopRow = 0;
  DayRow = 1;
  FirstDateRow = 2;
  LastDateRow = 7;
  LastCol = 7;
  TodayRow = 8;
  LastRow: word = 0;
  DefCalHeight = 160;
  DefCalWidth = 210;
  DefMinHeight = 120;
  DefMinWidth = 120;
  DefaultDisplayText = 'Today is,dd/mm/yyyy,Holidays during,There are no holidays set for';
  DefTStyle: TTextStyle = (Alignment  : taCenter; Layout     : tlCenter;
                           SingleLine : True;     Clipping   : True;
                           ExpandTabs : False;    ShowPrefix : False;
                           Wordbreak  : False;    Opaque     : False;
                           SystemFont : False;    RightToLeft: False;
                           EndEllipsis: False);

   //Ariel Rodriguez 12/09/2013
  EnglishDays = 'Sun,Mon,Tue,Wed,Thu,Fri,Sat';
  EnglishMonths = 'January,February,March,April,May,June,July,August,September,October,November,December';
  HebrewDays = 'א,ב,ג,ד,ה,ו,ש';
  HebrewMonths = ('ינואר,פברואר,מרץ,אפריל,מאי,יוני,    יולי,אוגוסט,ספטמבר,אוקטובר,נובמבר,דצמבר');
  HebrewTexts = 'היום הוא,yyyy-mm-dd,במהלך החגים, אין חגים מוגדרים עבור';
  FrenchDays = 'dim,lun,mar,mer,jeu,ven,sm';
  FrenchMonths = 'janvier,février,mars,avril,mai,juin,juillet,août,septembre,octobre,novembre,décembre';
  FrenchTexts = 'Est aujourd''hui,yyyy/mm/dd,vacances pendant,Il n''y a pas de jours fériés fixés pour';
  GermanMonths = 'Januar,Februar,März,April,Mai,Juni,Juli,August,September,Oktober,November,Dezember';
  GermanDays = 'Son,Mon,Die,Mit,Don,Fre,Sam';
  GermamTexts = 'Heute ist,yyyy/mm/dd,Urlaub während,Es gibt keine Feiertage eingestellt für';
  SpanishDays = 'Dom,Lun,Mar,Mie,Jue,Vie,Sab';
  SpanishMonths = 'Enero,Febrero,Marzo,Abril,Mayo,Junio,Julio,Agosto,Septiembre,Octubre,Noviembre,Diciembre';
  SpanishTexts = 'Hoy es,dd/mm/yyyy,Dias de fiestas,No hay dias feriados establecidos para';
   //Ariel Rodriguez 12/09/2013

type
  TCalendarLite = class;

  TColArray = array[1..LastCol] of word;
  TRowArray = array of word;

  TArrowDirection = (adLeft, adRight);
  TArrowhead = (ahSingle, ahDouble);
  TArrowPoints = array[1..3] of TPoint;

  TDayOfWeek = (dowSunday=1, dowMonday=2, dowTuesday=3, dowWednesday=4,
    dowThursday=5, dowFriday=6, dowSaturday=7);
  TDaysOfWeek = set of TDayOfWeek;

  TDisplayText = (dtToday=0, dtTodayFormat=1, dtHolidaysDuring=2, dtNoHolidaysDuring=3);

  THolidays = DWord;
  TGetHolidaysEvent = procedure (Sender: TObject; AMonth, AYear: Integer;
    var Holidays: THolidays) of object;

  TFormatEvent = procedure (Sender: TObject; ADate: TDate;
    AFont: TFont; ABkColor: TColor) of object;

  TCalOption = (coBoldDayNames, coBoldHolidays, coBoldToday, coBoldTopRow,
                coBoldWeekend, coDayLine, coShowBorder, coShowHolidays,
                coShowTodayFrame, coShowTodayName, coShowTodayRow,
                coShowWeekend, coUseTopRowColors);
  TCalOptions = set of TCalOption;

  TLanguage = (lgEnglish, lgFrench, lgGerman, lgHebrew, lgSpanish); //Ariel Rodriguez 12/09/2013


  { TCalDrawer }

  TCalDrawer = class
  private
    FBoundsRect: TRect;
    FCanvas: TCanvas;
    FCellSize: TSize;
    FColPositions: TColArray;
    FOwner: TCalendarLite;
    FRowPositions: TRowArray;
    FStartDate: TDateTime;
    FThisDay: word;
    FThisMonth: word;
    FThisYear: word;
    FTStyle: TTextStyle;
    procedure CalcSettings;
    procedure ChangeDateTo(ACell: TSize);
    procedure DrawArrow(ARect: TRect; AHead: TArrowhead; ADirec: TArrowDirection);
    procedure DrawDayCells;
    procedure DrawDayLabels;
    procedure DrawTodayRow;
    procedure DrawTopRow;
    function  GetCellAt(aPoint: TPoint): TSize;
    function  GetCellAtColRow(aCol, aRow: integer): TRect;
    function  GetColRowPosition(aCol, aRow: integer): TSize;
    function  GetLeftColIndex: Integer;
    procedure GetMonthYearRects(var AMonthRect, AYearRect: TRect);
    function  GetRightColIndex: Integer;
    procedure GotoDay(ADate: word);
    procedure GotoMonth(AMonth: word);
    procedure GotoToday;
    procedure GotoYear(AYear: word);
    procedure LeftClick;
    procedure RightClick;
  public
    constructor Create(ACanvas: TCanvas);
    procedure Draw;
  end;


  { TCalColors }

  TCalColors = class(TPersistent)
  private
    FOwner: TCalendarLite;
    FColors: Array[0..12] of TColor;
    function GetColor(AIndex: Integer): TColor;
    procedure SetColor(AIndex: Integer; AValue: TColor);
  public
    constructor Create(AOwner: TCalendarLite);
  published
    property ArrowBorderColor: TColor index 0 read GetColor write SetColor default clSilver;
    property ArrowColor: TColor index 1 read GetColor write SetColor default clSilver;
    property BackgroundColor: TColor index 2 read GetColor write SetColor default clWhite;
    property BorderColor: TColor index 3 read GetColor write SetColor default clSilver;
    property DaylineColor: TColor index 4 read GetColor write SetColor default clSilver;
    property HolidayColor: TColor index 5 read GetColor write SetColor default clRed;
    property PastMonthColor: TColor index 6 read GetColor write SetColor default clSilver;
    property SelectedDateColor: TColor index 7 read GetColor write SetColor default clMoneyGreen;
    property TextColor: TColor index 8 read GetColor write SetColor default clBlack;
    property TodayFrameColor: TColor index 9 read GetColor write SetColor default clLime;
    property TopRowColor: TColor index 10 read GetColor write SetColor default clHighlight;
    property TopRowTextColor: TColor index 11 read GetColor write SetColor default clHighlightText;
    property WeekendColor: TColor index 12 read GetColor write SetColor default clRed;
  end;


  { TCalendarLite }

//  TCalendarLite = class(TGraphicControl)
  TCalendarLite = class(TCustomControl)
  private
    FCalDrawer: TCalDrawer;
    FColors: TCalColors;
    FDate: TDateTime;
    FDayNames: TStringList;
    FDisplayTexts: TStringList;
    FMonthNames: TStringList;
    FOnDateChange: TNotifyEvent;
    FOnGetHolidays: TGetHolidaysEvent;
    FOptions: TCalOptions;
    FPopupMenu: TPopupMenu;
    FStartingDayOfWeek: TDayOfWeek;
    FWeekendDays: TDaysOfWeek;
    FLanguage: TLanguage; //Ariel Rodriguez 12/09/2013
    procedure DateChange;
    function GetDayNames: String;
    function GetDisplaytexts: String;
    function GetMonthNames: String;
    procedure HolidayMenuItemClicked(Sender: TObject);
    procedure MonthMenuItemClicked(Sender: TObject);
    procedure PopulateHolidayPopupMenu;
    procedure PopulateMonthPopupMenu;
    procedure PopulateYearPopupMenu;
    procedure SetDate(AValue: TDateTime);
    procedure SetDayNames(const AValue: String);
    procedure SetDefaultDisplayTexts;
    procedure SetDisplayTexts(AValue: String);
    procedure SetMonthNames(const AValue: String);
    procedure SetOptions(AValue: TCalOptions);
    procedure SetStartingDayOfWeek(AValue: TDayOfWeek);
    procedure SetWeekendDays(AValue: TDaysOfWeek);
    procedure YearMenuItemClicked(Sender: TObject);
    procedure SetLanguage(AValue: TLanguage); //Ariel Rodriguez 12/09/2013

  protected
    class function GetControlClassDefaultSize: TSize; override;
    function GetDayName(ADayOfWeek: TDayOfWeek): String;
    function GetDisplayText(aTextIndex: TDisplayText): String;
    function GetMonthName(AMonth: Integer): String;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    procedure MouseDown(Button: TMouseButton; Shift:TShiftState; X,Y:Integer); override;
    procedure Paint; override;

  public
    constructor Create(anOwner: TComponent); override;
    destructor Destroy; override;

  published
    property Align;
    property Anchors;
    property BiDiMode;
    property BorderSpacing;
    property Constraints;
    property Cursor;
    property Font;
    property Height;
    property HelpContext;
    property HelpKeyword;
    property HelpType;
    property Hint;
    property Left;
    property Name;
    property ParentBiDiMode;
    property ParentColor;
    property ParentFont;
    property PopupMenu;
    property ParentShowHint;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property Tag;
    property Top;
    property Visible;
    property Width;
    property OnChangeBounds;
    property OnClick;
    property OnContextPopup;
    property OnDblClick;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMouseDown;
    property OnMouseEnter;
    property OnMouseLeave;
    property OnMouseMove;
    property OnMouseUp;
    property OnMouseWheel;
    property OnMouseWheelDown;
    property OnMouseWheelUp;
    // new properties
    property Colors: TCalColors read FColors;
    property Date: TDateTime read FDate write SetDate;
    property DayNames: String read GetDayNames write SetDayNames;
    property DisplayTexts: String read GetDisplaytexts write SetDisplayTexts;
    property MonthNames: String read GetMonthnames write SetMonthNames;
    property Options: TCalOptions read FOptions write SetOptions
      default [coShowTodayFrame, coBoldHolidays, coShowWeekend, coShowHolidays, coShowTodayRow];
    property StartingDayOfWeek: TDayOfWeek read FStartingDayOfWeek
      write SetStartingDayOfWeek default dowSunday;
    property WeekendDays: TDaysOfWeek read FWeekendDays
      write SetWeekendDays default [dowSunday];
    property Languages: TLanguage read FLanguage
      write SetLanguage default lgEnglish; //Ariel Rodriguez 12/09/2013
  // new event properties
    property OnDateChange: TNotifyEvent read FOnDateChange write FOnDateChange;
    property OnGetHolidays: TGetHolidaysEvent read FOnGetHolidays write FOnGetHolidays;
  end;

procedure ClearHolidays(var AHolidays: THolidays);
procedure AddHoliday(ADay: Integer; var AHolidays: THolidays);
function  IsHoliday(ADay: Integer; AHolidays: THolidays): Boolean;

procedure Register; //Ariel Rodriguez 12/09/2013

implementation

uses
  LCLType, LazUTF8, dateutils, math;


{ Holiday helpers }

{ Clears the per month holiday buffer }
procedure ClearHolidays(var AHolidays: DWord);
begin
  AHolidays := 0;
end;

{ Set bit for given day to mark the day as a holiday }
procedure AddHoliday(ADay: Integer; var AHolidays: DWord);
begin
  AHolidays := DWord(1 shl ADay) or AHolidays;
end;

{ Check if the bit for the given day is set in AHolidays }
function IsHoliday(ADay: Integer; AHolidays: THolidays): Boolean;
begin
  Result := (AHolidays and DWord(1 shl ADay)) <> 0;
end;


{ TCalDrawer }

constructor TCalDrawer.Create(ACanvas: TCanvas);
begin
  inherited Create;
  FCanvas:= ACanvas;
  FTStyle:= DefTStyle;
end;

procedure TCalDrawer.CalcSettings;
var
  rem: Integer = 0;
  hSpc: Integer = 0;
  ch: Integer = 0;
  sp: Integer = 0;
  cw: Integer = 0;
  bit: integer=0;
  i, cellWidths, totalSpace, cellHeights,
  adjSpace, borderh, borderv, numRows: integer;
  sz: TSize;
begin
  if (FOwner.BiDiMode = bdLeftToRight) then
    FTStyle.RightToLeft:= False
  else
    FTStyle.RightToLeft:= True;
  SetLength(FRowPositions, 0);
  if (coShowTodayRow in FOwner.Options) then
    LastRow := TodayRow
  else
    LastRow := LastDateRow;
  SetLength(FRowPositions, LastRow+1);

  totalspace := Succ(LastCol)*3;
  sz := Size(FBoundsRect);
  cellWidths := sz.cx - totalSpace;
  DivMod(cellWidths, LastCol, cw, rem);
  FCellSize.cx := cw;
  adjSpace := sz.cx - LastCol*cw;
  DivMod(adjSpace, LastCol+1, hSpc, rem);
  borderh := (rem div 2) + 1;
  for i := Low(FColPositions) to High(FColPositions) do
    case FOwner.BiDiMode = bdLeftToRight of
      False : FColPositions[8-i]:= borderh + Pred(i)*cw + hSpc*i;
      True  : FColPositions[i]:= borderh + Pred(i)*cw + hSpc*i;
    end;
  case LastRow of
    LastDateRow : totalSpace := 12;
    TodayRow    : totalSpace := 14;
  end;

  cellHeights := sz.cy - totalSpace;
  numRows := Succ(LastRow);
  DivMod(cellHeights, numRows, ch, rem);
  FCellSize.cy := ch;
  adjSpace := sz.cy - numRows*ch;
  DivMod(adjSpace, totalSpace, sp, rem);
  rem := sz.cy - ch*numRows - totalSpace*sp;
  borderv := rem div 3;
  if (borderv = 0) then
    bit := rem + 1;
  rem := sp shl 1;
  cw := bit + borderv + rem;
  FRowPositions[TopRow] := cw;
  inc(cw, rem);
  FRowPositions[DayRow] := cw + ch;
  for i := FirstDateRow to LastDateRow do
    FRowPositions[i] := cw + i*ch + (i-1)*sp;
  if (LastRow = TodayRow) then
   FRowPositions[TodayRow] := FRowPositions[LastDateRow] + borderv + ch + rem;
end;

procedure TCalDrawer.ChangeDateTo(ACell: TSize);
var
  diff: integer;
  newDate: TDateTime;
  d, m, y: word;
begin
  diff := ACell.cx + LastCol * (ACell.cy - 2);
  newDate:= FStartDate + diff - 1;
  FOwner.FDate := newDate;
  FOwner.DateChange;
  FCanvas.Brush.Color := FOwner.Colors.BackgroundColor;
  FCanvas.FillRect(FBoundsRect);
  Self.Draw;
  DecodeDate(newDate, y, m, d);
end;

procedure TCalDrawer.Draw;
begin
  if not Assigned(FCanvas) then Exit;
  DecodeDate(FOwner.FDate, FThisYear, FThisMonth, FThisDay);
  CalcSettings;
  DrawTopRow;
  DrawDayLabels;
  DrawDayCells;
  DrawTodayRow;
end;

procedure TCalDrawer.DrawArrow(ARect: TRect; AHead: TArrowhead;
  ADirec: TArrowDirection);
var
  sz: TSize;
  d, ox, oy, half: integer;
  pts: TArrowPoints;
begin
  if (FCanvas.Brush.Color <> FOwner.Colors.ArrowColor) then
    FCanvas.Brush.Color:= FOwner.Colors.ArrowColor;
  if (FCanvas.Pen.Color <> FOwner.Colors.ArrowBorderColor) then
    FCanvas.Pen.Color := FOwner.Colors.ArrowBorderColor;
  sz := Size(aRect);
  d := Min(sz.cy, sz.cx) div 3;
  half := d div 2;
  ox := ARect.Left + (sz.cx - d) div 2;
  oy := ARect.Top + (sz.cy - d) div 2;
  case AHead of
   ahSingle:
     begin
       case ADirec of
         adLeft:
           begin
             pts[1]:= Point(ox+d, oy);
             pts[2]:= Point(ox, oy+half);
             pts[3]:= Point(ox+d, oy+d);
           end;
         adRight:
           begin
             pts[1]:= Point(ox, oy);
             pts[2]:= Point(ox, oy+d);
             pts[3]:= Point(ox+d, oy+half);
           end;
       end;
       FCanvas.Polygon(pts);
     end;
   ahDouble:
     case ADirec of
       adLeft:
         begin
           pts[1]:= Point(ox+half-1, oy);
           pts[2]:= Point(ox-1, oy+half);
           pts[3]:= Point(ox+half-1, oy+d);
           FCanvas.Polygon(pts);
           pts[1]:= Point(ox+d, oy);
           pts[2]:= Point(ox+half, oy+half);
           pts[3]:= Point(ox+d, oy+d);
           FCanvas.Polygon(pts);
         end;
       adRight:
         begin
           pts[1]:= Point(ox, oy);
           pts[2]:= Point(ox+half, oy+half);
           pts[3]:= Point(ox, oy+d);
           FCanvas.Polygon(pts);
           pts[1]:= Point(ox+half+1, oy);
           pts[2]:= Point(ox+d+1, oy+half);
           pts[3]:= Point(ox+half+1, oy+d);
           FCanvas.Polygon(pts);
         end;
     end;
  end;
end;

procedure TCalDrawer.DrawDayCells;
var
  remDays: integer = 0;
  startRow: Integer = 0;
  holidays: THolidays = 0;
  r, c, startCol, startSpan: integer;
  rec: TRect;
  s: string;
  dow, y, m, d: word;
  partWeeks: Integer;
  dt, todayDate: TDateTime;
begin
  todayDate := Date;
  dow := DayOfWeek(FOwner.FDate);
  c := dow - integer(FOwner.FStartingDayOfWeek);
  if (c < 0) then Inc(c, 7);
  startCol := Succ(c);
  partweeks := FThisDay - startCol;
  DivMod(partWeeks, 7, startRow, remDays);
  if (remDays > 0) then Inc(startRow, 1);
  startspan := startRow*7 + startCol - 1;
  FStartDate := FOwner.FDate - startSpan;
  dt := FStartDate;
  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:
          begin
            FCanvas.Font.Color:= FOwner.Colors.TextColor;
            FCanvas.Font.Style := [];
            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
            if (coShowWeekend in FOwner.Options) and
               (TDayOfWeek(DayOfWeek(dt)) in FOwner.FWeekendDays) then
            begin
              FCanvas.Font.Color := FOwner.Colors.WeekendColor;
              if coBoldWeekend in FOwner.Options then
                FCanvas.Font.Style := [fsBold];
            end;
          end;
      end;
      s := IntToStr(d);
      if (dt = FOwner.FDate) then
      begin
        FCanvas.Brush.Color:= FOwner.FColors.SelectedDateColor;
        FCanvas.FillRect(rec);
      end
      else
        FCanvas.Brush.Color:= FOwner.Colors.BackgroundColor;

      FCanvas.TextRect(rec, 0, 0, s, FTStyle);
      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;
      end;
      dt:= dt + 1;
    end;  // for c
end;

procedure TCalDrawer.DrawDayLabels;
var
  c, map: integer;
  rec: TRect;
  lbls: TWeekNameArray;
begin
  FCanvas.Font.Color:= FOwner.Colors.TextColor;
  if (coBoldDayNames in FOwner.Options) then
    FCanvas.Font.Style := [fsBold]
  else
    FCanvas.Font.Style := [];
  map := Integer(FOwner.FStartingDayOfWeek);
  for c:= Low(TWeekNameArray) to High(TWeekNameArray) do
  begin
    if (map > High(TWeekNameArray)) then map := Low(TWeekNameArray);
    lbls[c] := FOwner.GetDayName(TDayOfWeek(map));
    inc(map);
  end;
  for c:= Low(FColPositions) to High(FColPositions) do
  begin
    rec := GetCellAtColRow(c, DayRow);
    FCanvas.TextRect(rec, 0, 0, lbls[c], FTStyle);
  end;
  if (coDayLine in FOwner.Options) then begin
    rec := GetCellAtColRow(GetLeftColIndex, DayRow);
    rec.Right := GetCellAtColRow(GetRightColIndex, DayRow).Right;
    rec.Bottom := rec.Top;
    FCanvas.Pen.Color := FOwner.Colors.DayLineColor;
    FCanvas.Line(rec);
  end;
end;

procedure TCalDrawer.DrawTodayRow;
var
  r1, r2: TRect;
  w1, w2, w3, rem, halfRem: integer;
  s: String;
begin
  if (LastRow <> TodayRow) then Exit;
  r1 := GetCellAtColRow(2, TodayRow);

  if coUseTopRowColors in FOwner.Options then begin
    if (FCanvas.Font.Color <> FOwner.Colors.TopRowTextColor)
      then FCanvas.Font.Color:= FOwner.Colors.TopRowTextColor;
    FCanvas.Brush.Color := FOwner.Colors.TopRowColor;
    FCanvas.FillRect(r1);
  end else
  if (FCanvas.Font.Color <> FOwner.Colors.TextColor) then
    FCanvas.Font.Color:= FOwner.Colors.TextColor;

  if coBoldToday in FOwner.Options then
    FCanvas.Font.Style := [fsBold] else
    FCanvas.Font.Style := [];

  s:= FOwner.GetDisplayText(dtToday);
  if (coShowTodayName in FOwner.Options) then
    s := Format('%s %s',[s, FOwner.GetDayName(TDayOfWeek(DayOfWeek(Date())))]);
  AppendStr(s, ' ' + FormatDateTime(FOwner.GetDisplayText(dtTodayFormat), Date()));
  w1 := FCanvas.TextWidth('aaa');
  w2 := FCanvas.TextWidth(' ');
  w3 := FCanvas.TextWidth(s);
  rem := Size(r1).cx - w1 - w2 - w3;
  halfRem := rem div 2;
  if (rem < 0) then
  begin
    Inc(r1.Left, halfRem);
    Dec(r1.Right, halfRem);
    rem := 0;
  end;
  r2:= r1;

  r1.Left := r1.Left + halfRem;
  r1.Right := r1.Left + w1;
  InflateRect(r1, 0, -FCellSize.cy div 5);
  if (FCanvas.Pen.Color <> FOwner.Colors.TodayFrameColor) then
    FCanvas.Pen.Color := FOwner.Colors.TodayFrameColor;
  FCanvas.Pen.Width := 2;
  FCanvas.Frame(r1);
  FCanvas.Pen.Width := 1;

  r2.Left := r1.Right + w2;
  r2.Right := r2.Left + w3 + 2;
  if (coBoldToday in FOwner.Options) then
    FCanvas.Font.Style := [fsBold]
  else
    FCanvas.Font.Style := [];
  FCanvas.TextRect(r2, 0, 0, s, FTStyle);
end;

procedure TCalDrawer.DrawTopRow;
var
  r: TRect;
  s: String;
begin
  if coUseTopRowColors in FOwner.Options then begin
    FCanvas.Font.Color:= FOwner.Colors.TopRowTextColor;
    FCanvas.Brush.Color := FOwner.Colors.TopRowColor;
    r := GetCellAtColRow(GetLeftColIndex, TopRow);
    r.Right := GetCellAtColRow(GetRightColIndex, TopRow).Right;
    FCanvas.FillRect(r);
  end else
  if (FCanvas.Font.Color <> FOwner.Colors.TextColor) then
    FCanvas.Font.Color:= FOwner.Colors.TextColor;
  if (coBoldTopRow in FOwner.Options) then
    FCanvas.Font.Style := [fsBold]
  else
    FCanvas.Font.Style := [];

  case (FOwner.BiDiMode = bdLeftToRight) of
    False: begin
             r:= GetCellAtColRow(7, TopRow); DrawArrow(r, ahDouble, adLeft);
             r:= GetCellAtColRow(6, TopRow); DrawArrow(r, ahSingle, adLeft);
             r:= GetCellAtColRow(1, TopRow); DrawArrow(r, ahDouble, adRight);
             r:= GetCellAtColRow(2, TopRow); DrawArrow(r, ahSingle, adRight);
             r:= GetCellAtColRow(3, TopRow);
           end;
    True: begin
            r:= GetCellAtColRow(1, TopRow); DrawArrow(r, ahDouble, adLeft);
            r:= GetCellAtColRow(2, TopRow); DrawArrow(r, ahSingle, adLeft);
            r:= GetCellAtColRow(7, TopRow); DrawArrow(r, ahDouble, adRight);
            r:= GetCellAtColRow(6, TopRow); DrawArrow(r, ahSingle, adRight);
            r:= GetCellAtColRow(3, TopRow);
          end;
  end;
  s := FOwner.GetMonthName(FThisMonth) + ' ' + IntToStr(FThisYear);
  FCanvas.TextRect(r, 0, 0, s, FTStyle);
end;

function TCalDrawer.GetCellAt(aPoint: TPoint): TSize;
var
  x: integer;
begin
  case FOwner.BiDiMode <> bdLeftToRight of
   False:
     for x := Low(FColPositions) to High(FColPositions) do
       if FColPositions[x] >= aPoint.x then
       begin
         Result.cx := x-1;
         Break;
       end else
         Result.cx := LastCol;
   True:
     for x:= High(FColPositions) downto Low(FColPositions) do
       if FColPositions[x] >= aPoint.x then
       begin
         Result.cx := x+1;
         Break;
       end else
         Result.cx := 1;
  end;
  for x := 1 to High(FRowPositions) do
    if FRowPositions[x] >= aPoint.y then
    begin
      Result.cy := x-1;
      Break;
    end
    else
      Result.cy := High(FRowPositions);
end;

function TCalDrawer.GetCellAtColRow(aCol, aRow: integer): TRect;
var
  sz: TSize;
  mid, midmid, midhi, midmidhi, half, fraction: integer;
begin
  sz := GetColRowPosition(aCol, aRow);
  Result.Top := sz.cy;
  Result.Bottom := Result.Top + FCellSize.cy;
  half := FCellSize.cx div 2;
  case aRow of
    TopRow:
      begin
        case (FOwner.BiDiMode = bdLeftToRight) of
          True:
            begin                             // LeftToRight
              mid := FColPositions[2] + half;
              fraction := (mid - FColPositions[1]) div 2;
              midmid := FColPositions[1] + fraction;
              midhi := FColPositions[6] + half;
              midmidhi := midhi + fraction;
            end;
          False:
            begin                            // RightToLeft
              mid := FColPositions[6] + half;
              fraction := (mid - FColPositions[7]) div 2;
              midmid := FColPositions[7] + fraction;
              midhi := FColPositions[2] + half;
              midmidhi := midhi + fraction;
              aCol := 8 - aCol;
            end;
        end;
        case aCol of
          1:
            begin
              Result.Left := sz.cx;
              Result.Right := midmid;
            end;
          2:
            begin
              Result.Left := midmid;
              Result.Right := mid;
            end;
          3..5:
            begin
              Result.Left := mid;
              Result.Right := midhi;
            end;
          6:
            begin
              Result.Right := midmidhi;
              Result.Left := midhi;
            end;
          7:
            begin
              Result.Left := midmidhi;
              Result.Right := midmidhi + fraction;
            end;
        end;
      end;

    TodayRow:
      begin
        Result.Left := GetColRowPosition(GetLeftColIndex, TodayRow).cx;
        Result.Right := GetColRowPosition(GetRightColIndex, TodayRow).cx + FCellSize.cx;
      end;

    else
      Result.Left := sz.cx;
      Result.Right := Result.Left + FCellSize.cx;
  end;
end;

function TCalDrawer.GetColRowPosition(aCol, aRow: integer): TSize;
begin
  Result.cy:= FRowPositions[aRow];
  Result.cx:= FColPositions[aCol];
end;

function TCalDrawer.GetLeftColIndex: Integer;
begin
  if FOwner.BiDiMode = bdLeftToRight then
    Result := 1
  else
    Result := 7;
end;

procedure TCalDrawer.GetMonthYearRects(var AMonthRect, AYearRect: TRect);
var
  sm, sy: string;
  w: Integer;
  r: TRect;
begin
  AMonthRect := GetCellAtColRow(3, TopRow);
  AYearRect := AMonthRect;
  if (coBoldTopRow in FOwner.Options) then
    FCanvas.Font.Style := [fsBold]
  else
    FCanvas.Font.Style := [];
  sm := FOwner.GetMonthName(FThisMonth);
  sy := IntToStr(FThisYear);
  w := FCanvas.TextWidth(sm + ' ' + sy);
  AMonthRect.Left := (FOwner.Width - w) div 2;
  AMonthRect.Right := AMonthRect.Left + FCanvas.TextWidth(sm);
  AYearRect.Right := (FOwner.Width + w) div 2;
  AYearRect.Left := AYearRect.Right - FCanvas.TextWidth(sy);
  if (FOwner.BiDiMode <> bdLeftToRight) then
  begin
    r := AMonthRect;
    AMonthRect := AYearRect;
    AYearRect := r;
  end;
end;

function TCalDrawer.GetRightColIndex: Integer;
begin
  if FOwner.BiDiMode = bdLeftToRight then
    Result := 7
  else
    Result := 1;
end;

procedure TCalDrawer.GotoDay(ADate: word);
begin
  FOwner.Date := ADate;
end;

procedure TCalDrawer.GotoMonth(AMonth: word);
var
  d: TDate;
begin
  if not TryEncodeDate(FThisYear, AMonth, FThisDay, d) then  // Feb 29 in leap year!
    d := EncodeDate(FThisYear, AMonth, FThisDay);
  FOwner.Date := d;
end;

procedure TCalDrawer.GotoToday;
begin
  FOwner.Date:= Date();
end;

procedure TCalDrawer.GotoYear(AYear: word);
var
  d: TDate;
begin
  if not TryEncodeDate(AYear, FThisMonth, FThisDay, d) then  // Feb 29 in leap year!
    d := EncodeDate(AYear, FThisMonth, FThisDay);
  FOwner.Date := d;
end;

procedure TCalDrawer.LeftClick;
var
  p, ppopup: TPoint;
  cell: TSize;
  Rm, Ry: TRect;
begin
  p := FOwner.ScreenToClient(Mouse.CursorPos);
  cell := GetCellAt(p);
  case cell.cy of
    TopRow:
      case cell.cx of
        1: FOwner.Date := IncYear(FOwner.Date, -1);
        2: FOwner.Date := IncMonth(FOwner.Date, -1);
        3..5:
          begin
            GetMonthYearRects(Rm{%H-}, Ry{%H-});
            if PtInRect(Rm, p) then begin
              FOwner.PopulateMonthPopupMenu;
              ppopup := FOwner.ClientToScreen(Point(Rm.Left, Rm.Bottom));
              FOwner.FPopupMenu.PopUp(ppopup.x, ppopup.y);
            end;
            if PtInRect(Ry, p) then begin
              FOwner.PopulateYearPopupMenu;
              ppopup := FOwner.ClientToScreen(Point(Ry.Left, Ry.Bottom));
              FOwner.FPopupMenu.Popup(ppopup.x, ppopup.y);
            end;
          end;
        6: FOwner.Date := IncMonth(FOwner.Date, +1);
        7: FOwner.Date := IncYear(FOwner.Date, +1);
      end;

    DayRow: ;

    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
  begin
    FOwner.PopulateHolidayPopupMenu;
    FOwner.FPopupMenu.PopUp(Mouse.CursorPos.x, Mouse.CursorPos.y);
  end;
end;


{ TCalColors }

constructor TCalColors.Create(AOwner: TCalendarLite);
begin
  inherited Create;
  FOwner := AOwner;
  FColors[0] := clSilver;          //  ArrowBorderColor: clSilver;
  FColors[1] := clSilver;          //  ArrowColor:  clSilver;
  FColors[2] := clWhite;           //  BackgroundColor:  clWhite;
  FColors[3] := clSilver;          //  BorderColor:  clSilver;
  FColors[4] := clSilver;          //  DaylineColor: clSilver;
  FColors[5] := clRed;             //  HolidayColor: clRed;
  FColors[6] := clSilver;          //  PastMonthColor:  clSilver;
  FColors[7] := clMoneyGreen;      //  SelectedDateColor: clMoneyGreen;
  FColors[8] := clBlack;           //  TextColor: clBlack;
  FColors[9] := clGray;            //  TodayFrameColor:  clGray;
  FColors[10] := clHighlight;      //  TopRowColor:  clHighlight;
  FColors[11] := clHighlightText;  //  TopRowTextColor:  clHighlightText;
  FColors[12] := clRed;            //  WeekendColor:  clRed;
end;

function TCalColors.GetColor(AIndex: Integer): TColor;
begin
  Result := FColors[AIndex];
end;

procedure TCalColors.SetColor(AIndex: Integer; AValue: TColor);
begin
  if FColors[AIndex] = AValue then exit;
  FColors[AIndex] := AValue;
  FOwner.Invalidate;
end;


{ TCalendarLite }

constructor TCalendarLite.Create(anOwner: TComponent);
begin
  inherited Create(anOwner);
  FColors := TCalColors.Create(self);
  FDate := SysUtils.Date;
  Color := clWhite;
  FStartingDayOfWeek:= dowSunday;
  with GetControlClassDefaultSize do
    SetInitialBounds(0, 0, cx, cy);
  Constraints.MinHeight := DefMinHeight;
  Constraints.MinWidth := DefMinWidth;
  Canvas.Brush.Style := bsSolid;
  TabStop := true;
  FDayNames := TStringList.Create;
  FMonthNames := TStringList.Create;
  FDisplayTexts := TStringList.Create;
  FDisplayTexts.StrictDelimiter := True;
  FDisplayTexts.Delimiter := ',';
  SetDefaultDisplayTexts;
  FPopupMenu := TPopupMenu.Create(Self);
  FCalDrawer := TCalDrawer.Create(Canvas);
  FCalDrawer.FOwner:= Self;
  FWeekendDays := [dowSunday, dowSaturday];
  FOptions := [coShowTodayFrame, coBoldHolidays, coShowWeekend, coShowHolidays,
               coShowTodayRow];
  FLanguage := lgEnglish; //Ariel Rodriguez 12/09/2013
end;

destructor TCalendarLite.Destroy;
begin
  FreeAndNil(FDayNames);
  FreeAndNil(FMonthNames);
  FreeAndNil(FDisplayTexts);
  FreeAndNil(FColors);
  SetLength(FCalDrawer.FRowPositions, 0);
  FreeAndNil(FCalDrawer);
  inherited Destroy;
end;

procedure TCalendarLite.DateChange;
begin
  if Assigned(FOnDateChange) then
    FOnDateChange(Self);
end;

class function TCalendarLite.GetControlClassDefaultSize: TSize;
begin
  Result.cx := DefCalWidth;
  Result.cy := DefCalHeight;
end;

function TCalendarLite.GetDayName(ADayOfWeek: TDayOfWeek): String;
begin
  Result := SysToUTF8(DefaultFormatSettings.ShortDayNames[integer(ADayOfWeek)]);
  if Pred(integer(ADayOfWeek)) < FDayNames.Count then
    Result := FDayNames[Pred(integer(ADayOfWeek))];
end;

function TCalendarLite.GetDayNames: String;
begin
  Result := FDayNames.CommaText;
end;

function TCalendarLite.GetDisplayText(aTextIndex: TDisplayText): String;
begin
  Result := FDisplayTexts[Integer(aTextIndex)];
end;

function TCalendarLite.GetDisplayTexts: String;
begin
  Result := FDisplayTexts.CommaText;
end;

function TCalendarLite.GetMonthName(AMonth: Integer): String;
begin
  Result := SysToUTF8(DefaultFormatSettings.LongMonthNames[AMonth]);
  if pred(AMonth) < FMonthnames.Count then
    Result := FMonthNames[pred(AMonth)];
end;

function TCalendarLite.GetMonthNames: String;
begin
  Result := FMonthNames.CommaText;
end;

procedure TCalendarLite.HolidayMenuItemClicked(Sender: TObject);
begin
  FCalDrawer.GotoDay(TMenuItem(Sender).Tag);
end;

procedure TCalendarLite.KeyDown(var Key: Word; Shift: TShiftState);

  function Delta(Increase: Boolean): Integer;
  begin
    if Increase then Result := +1 else Result := -1;
  end;

begin
  case Key of
    VK_UP,
    VK_DOWN  : Date := IncWeek(FDate, Delta(Key = VK_DOWN));
    VK_LEFT,
    VK_RIGHT : Date := IncDay(FDate, Delta(Key = VK_RIGHT));
    VK_HOME  : Date := StartOfTheMonth(FDate);
    VK_END   : Date := EndOfTheMonth(FDate);
    VK_PRIOR,
    VK_NEXT  : if (ssCtrl in Shift) then
                 Date := IncYear(FDate, Delta(Key = VK_NEXT)) else
                 Date := IncMonth(FDate, Delta(Key = VK_NEXT));
    else       inherited;
               exit;
  end;

  Key := 0;
  inherited;
end;

procedure TCalendarLite.MouseDown(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
  inherited MouseDown(Button, Shift, X, Y);

  if not Focused and not(csNoFocus in ControlStyle) then
    SetFocus;

  case Button of
    mbLeft  : FCalDrawer.LeftClick;
    mbRight : FCalDrawer.RightClick;
  end;
end;

procedure TCalendarLite.MonthMenuItemClicked(Sender: TObject);
begin
  FCalDrawer.GotoMonth(TMenuItem(Sender).Tag);
end;

procedure TCalendarLite.Paint;
var
  r: TRect;
begin
  if Assigned(FCalDrawer) then
  begin
    if ParentColor then
      Colors.BackgroundColor := Parent.Color;
    if ParentFont then
    begin
      if (Parent.Font <> FCalDrawer.FCanvas.Font)
        then FCalDrawer.FCanvas.Font := Parent.Font
      else if (Canvas.Font.Color <> Colors.TextColor)
        then FColors.TextColor := Canvas.Font.Color;
    end;

    case (BiDiMode = bdLeftToRight) of
     False: if not FCalDrawer.FTStyle.RightToLeft then
              FCalDrawer.FTStyle.RightToLeft := True;
     True : if FCalDrawer.FTStyle.RightToLeft then
             FCalDrawer.FTStyle.RightToLeft := False;
    end;

    Canvas.Brush.Color:= Colors.BackGroundColor;
    Canvas.FillRect(ClientRect);
    if (coShowBorder in FOptions) then
    begin
      if (Canvas.Pen.Color <> FColors.BorderColor) then
        Canvas.Pen.Color := FColors.BorderColor;
      Canvas.Frame(ClientRect);
    end;

    r:= ClientRect;
    if (coShowBorder in FOptions) then InflateRect(r, -1, -1);
    FCalDrawer.FBoundsRect:= r;
    FCalDrawer.Draw;
  end;

  inherited Paint;
end;

procedure TCalendarLite.PopulateHolidayPopupMenu;
var
  item: TMenuItem;
  m, d, dayCount: Integer;
  population: integer = 0;
  hols: THolidays = 0;
  dt: TDateTime;
begin
  with FPopupMenu.Items do begin
    Clear;
    item:= TMenuItem.Create(Self);
    item.Caption:= Format('%s %d', [GetDisplayText(dtHolidaysDuring), FCalDrawer.FThisYear]);
    Add(item);
    item:= TMenuItem.Create(Self);
    item.Caption:= '-';
    Add(item);
    for m:= 1 to 12 do
    begin
      ClearHolidays(hols);
      FOnGetHolidays(Self, m, FCalDrawer.FThisYear, hols);
      dayCount:= DaysInAMonth(FCalDrawer.FThisYear, m);
      d := 1;
      repeat
        if IsHoliday(d, hols) then
        begin
          item := TMenuItem.Create(Self);
          inc(population);
          item.Caption:= IntToStr(d) + ' ' + GetMonthName(m);
          if (m = FCalDrawer.FThisMonth) then
            item.Checked := True;
          dt := EncodeDate(FCalDrawer.FThisYear, m, d);
          item.Tag := trunc(dt);
          item.OnClick := @HolidayMenuItemClicked;
          Add(item);
        end;
        inc(d)
      until d > dayCount;
    end;
    Items[0].Enabled := (population <> 0);
    if not Items[0].Enabled then
      Items[0].Caption := Format('%s %d', [GetDisplayText(dtNoHolidaysDuring), FCalDrawer.FThisYear]);
  end;
end;

procedure TCalendarLite.PopulateMonthPopupMenu;
var
  m: Integer;
  item: TMenuItem;
begin
  with FPopupMenu.Items do begin
    Clear;
    for m := 1 to 12 do
    begin
      item := TMenuItem.Create(self);
      item.Caption := GetMonthName(m);
      item.OnClick := @MonthMenuItemClicked;
      item.Tag := m;
      if m = FCalDrawer.FThisMonth then
        item.Checked := true;
      Add(item);
    end;
  end;
end;

procedure TCalendarLite.PopulateYearPopupMenu;
var
  y: Integer;
  item: TMenuItem;
begin
  with FPopupMenu.Items do begin
    Clear;
    for y := FCalDrawer.FThisYear - 10 to FCalDrawer.FThisYear + 10 do
    begin
      item := TMenuItem.Create(self);
      item.Caption := IntToStr(y);
      item.OnClick := @YearMenuItemClicked;
      item.Tag := y;
      if y = FCalDrawer.FThisYear then
        item.Checked := true;
      if (FCalDrawer.FThisDay = 29) and (FCalDrawer.FThisMonth = 2) and not IsLeapYear(y)
        then item.Enabled:= False;
      Add(item);
    end;
  end;
end;

procedure TCalendarLite.SetDate(AValue: TDateTime);
begin
  if FDate = AValue then Exit;
  FDate := AValue;
  DateChange;
  Invalidate;
end;

procedure TCalendarLite.SetDayNames(const AValue: String);
begin
  FDayNames.CommaText := AValue;
  Invalidate;
end;

procedure TCalendarLite.SetDefaultDisplayTexts;
begin
  FDisplayTexts.CommaText := DefaultDisplayText;
end;

procedure TCalendarLite.SetDisplayTexts(AValue: String);
begin
  FDisplayTexts.CommaText := AValue;
  Invalidate;
end;

//Ariel Rodriguez 12/09/2013
procedure TCalendarLite.SetLanguage(AValue : TLanguage);
begin
  if FLanguage = AValue then Exit;
  FLanguage := AValue;

  case FLanguage of
    lgEnglish: begin
                 DayNames := EnglishDays;
                 MonthNames := EnglishMonths;
                 DisplayTexts := DefaultDisplayText;
                 BiDiMode:= bdLeftToRight;
               end;
    lgFrench: begin
                 DayNames := FrenchDays;
                 MonthNames := FrenchMonths;
                 DisplayTexts := FrenchTexts;
                 BiDiMode:= bdLeftToRight;
             end;
    lgGerman: begin
                 DayNames := GermanDays;
                 MonthNames := GermanMonths;
                 DisplayTexts := GermamTexts;
                 BiDiMode:= bdLeftToRight;
               end;
    lgHebrew: begin
                 DayNames := HebrewDays;
                 MonthNames := HebrewMonths;
                 DisplayTexts := HebrewTexts;
                 BiDiMode:= bdRightToLeft;
               end;
    lgSpanish: begin
                 DayNames := SpanishDays;
                 MonthNames := SpanishMonths;
                 DisplayTexts := SpanishTexts;
                 BiDiMode:= bdLeftToRight;
               end;
  end;

  Invalidate;
end;

//Ariel Rodriguez 12/09/2013
procedure TCalendarLite.SetMonthNames(const AValue: String);
begin
  FMonthNames.CommaText := AValue;
  Invalidate;
end;

procedure TCalendarLite.SetStartingDayOfWeek(AValue: TDayOfWeek);
begin
  if FStartingDayOfWeek = AValue then Exit;
  FStartingDayOfWeek := AValue;
  Invalidate;
end;

procedure TCalendarLite.SetOptions(AValue: TCalOptions);
begin
  if FOptions = AValue then Exit;
  FOptions := AValue;
  case (coShowTodayRow in FOptions) of
    False: if LastRow <> LastDateRow then LastRow := LastDateRow;
    True : if LastRow <> TodayRow then LastRow := TodayRow;
  end;
  if Length(FCalDrawer.FRowPositions) <> LastRow+1 then
    SetLength(FCalDrawer.FRowPositions, LastRow+1);
  Invalidate;
end;

procedure TCalendarLite.SetWeekendDays(AValue: TDaysOfWeek);
begin
  if FWeekendDays = AValue then Exit;
  FWeekendDays := AValue;
  Invalidate;
end;

procedure TCalendarLite.YearMenuItemClicked(Sender: TObject);
begin
  FCalDrawer.GotoYear(TMenuItem(Sender).Tag);
end;

//Ariel Rodriguez 12/09/2013
procedure Register;
begin
  {$I calendarlite_icon.lrs}
  RegisterComponents('Misc', [TCalendarLite]);
end;
//Ariel Rodriguez 12/09/2013

end.