lazarus-ccr/components/tvplanit/source/vpcalendar.pas

{*********************************************************}
{*                 VPCALENDAR.PAS 1.03                   *}
{*********************************************************}

{* ***** BEGIN LICENSE BLOCK *****                                            *}
{* Version: MPL 1.1                                                           *}
{*                                                                            *}
{* The contents of this file are subject to the Mozilla Public License        *}
{* Version 1.1 (the "License"); you may not use this file except in           *}
{* compliance with the License. You may obtain a copy of the License at       *}
{* http://www.mozilla.org/MPL/                                                *}
{*                                                                            *}
{* Software distributed under the License is distributed on an "AS IS" basis, *}
{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License   *}
{* for the specific language governing rights and limitations under the       *}
{* License.                                                                   *}
{*                                                                            *}
{* The Original Code is TurboPower Visual PlanIt                              *}
{*                                                                            *}
{* The Initial Developer of the Original Code is TurboPower Software          *}
{*                                                                            *}
{* Portions created by TurboPower Software Inc. are Copyright (C) 2002        *}
{* TurboPower Software Inc. All Rights Reserved.                              *}
{*                                                                            *}
{* Contributor(s):                                                            *}
{*                                                                            *}
{* ***** END LICENSE BLOCK *****                                              *}

{$I vp.inc}

unit VpCalendar;
  {-Calendar component}
                            
interface

uses
  {$IFDEF LCL}
  LMessages, LCLProc, LCLType, LCLIntf, FileUtil,
  {$ELSE}
  Windows, Messages,
  {$ENDIF}
  SysUtils, Buttons, Classes, Controls, Forms, Graphics, Menus,
  VpConst, VpBase, VpSR, VpMisc, VpBaseDS, VpCanvasUtils, VpException;

type
  TVpCalDisplayOption = (cdoShortNames, cdoShowYear, cdoShowInactive,
                         cdoShowRevert, cdoShowToday, cdoShowNavBtns,
                         cdoHideActive, cdoHighlightSat, cdoHighlightSun);

  TVpCalDisplayOptions = set of TVpCalDisplayOption;

  TVpCalColorArray = array[0..6] of TColor;

  TVpCalColorScheme = (cscalCustom, cscalClassic, cscalWindows,
                       cscalGold, cscalOcean, cscalRose);

  TVpCalSchemeArray = array[TVpCalColorScheme] of TVpCalColorArray;

  TRowArray = array[0..8] of Integer;
  TColArray = array[0..6] of Integer;

const
  {ActiveDay, DayNames, Days, InactiveDays, MonthAndYear, Weekend}
  CalScheme : TVpCalSchemeArray =
    ((0, 0, 0, 0, 0, 0, 0),
     (clHighlight, clWindow, clWindow,  clWindow, clWindow, clWindow, clBlack),
     (clRed,       clMaroon, clBlack,   clGray,   clBlue,   clRed, clBlack),
     (clBlack,     clBlack,  clYellow,  clGray,   clBlack,  clTeal, clBlack),
     (clBlack,     clBlack,  clAqua,    clGray,   clBlack,  clNavy, clBlack),
     (clRed,       clRed,    clFuchsia, clGray,   clBlue,   clTeal, clBlack)
    );
  calDefWeekStarts = dtSunday;  { default start of the week }

type
  TVpCalColors = class(TPersistent)
  protected {private}
    {property variables}
    FUpdating     : Boolean;
    FOnChange     : TNotifyEvent;

    {internal variables}
    SettingScheme : Boolean;

    {property methods}
    function GetColor(Index: Integer): TColor;
    procedure SetColor(Index: Integer; Value: TColor);
    procedure SetColorScheme(Value: TVpCalColorScheme);

    {internal methods}
    procedure DoOnChange;

  public
    {public property variables}
    FCalColors: TVpCalColorArray;
    FColorScheme: TVpCalColorScheme;
    procedure Assign(Source : TPersistent); override;
    procedure BeginUpdate;
    procedure EndUpdate;

    property OnChange : TNotifyEvent read  FOnChange write FOnChange;

  published
    property ActiveDay: TColor index 0 read  GetColor write SetColor;
    property ColorScheme: TVpCalColorScheme read  FColorScheme write SetColorScheme;
    property DayNames: TColor index 1 read  GetColor write SetColor;
    property Days: TColor index 2 read  GetColor write SetColor;
    property InactiveDays: TColor index 3 read  GetColor write SetColor;
    property MonthAndYear: TColor index 4 read  GetColor write SetColor;
    property Weekend: TColor index 5 read  GetColor write SetColor;
    property EventDays: TColor index 6 read GetColor write SetColor;
  end;

type
  TDateChangeEvent = procedure(Sender: TObject; Date: TDateTime) of object;
  TCalendarDateEvent = procedure(Sender: TObject; ADate: TDateTime; const Rect: TRect) of object;
  TGetHighlightEvent = procedure(Sender: TObject; ADate: TDateTime; var Color: TColor) of object;
  TGetDateEnabledEvent = procedure(Sender: TObject; ADate: TDateTime; var Enabled: Boolean) of object;

  TVpCustomCalendar = class(TVpLinkableControl)
  protected {private}
    {property variables}
    FBorderStyle     : TBorderStyle;
    FBrowsing        : Boolean;
    FColors          : TVpCalColors;
    FOptions         : TVpCalDisplayOptions;
    FDate            : TDateTime;
    FDay             : Integer;               {calendar day}
    FDateFormat      : TVpDateFormat;
    FDayNameWidth    : TVpDayNameWidth;
    FDrawHeader      : Boolean;               {true to draw day name header}
    FMonth           : Integer;               {calendar month}
    FReadOnly        : Boolean;               {true if in read only mode}
    FWantDblClicks   : Boolean;               {true to include cs_dblclks style}
    FWeekStarts      : TVpDayType;            {the day that begins the week}
    FYear            : Integer;               {calendar year}
    FLastRenderX     : Integer;
    FLastRenderY     : Integer;
    FDefaultPopup    : TPopupMenu;

    {event variables}
    FOnChange        : TDateChangeEvent;
    FOnDrawDate      : TCalendarDateEvent;
    FOnDrawItem      : TCalendarDateEvent;
    FOnGetDateEnabled: TGetDateEnabledEvent;
    FOnGetHighlight  : TGetHighlightEvent;

    {internal variables}
    clInLinkHandler  : Boolean;
    clBtnLeft        : TSpeedButton;
    clBtnRevert      : TSpeedButton;
    clBtnRight       : TSpeedButton;
    clBtnToday       : TSpeedButton;
    clInPopup        : Boolean;
    clBtnNextYear    : TSpeedButton;
    clBtnPrevYear    : TSpeedButton;
    clCalendar       : array[1..49] of Byte; {current month grid}
    clDay            : Word;
    clFirst          : Byte; {index for first day in current month}
    clLast           : Byte; {index for last day in current month}
    clMonth          : Word;
    clRowCol         : array[0..8, 0..6] of TRect; {cell TRect info}
    cSettingScheme   : Boolean;
    clYear           : Word;
    clWidth          : Integer;   {client width - margins}
    clMask           : array[0..MaxDateLen] of AnsiChar; {default date mask}
    clPopup          : Boolean;   {true if being created as a popup}
    clRevertDate     : TDateTime; {date on entry}
    clRowCount       : Integer;   {7 if no header, otherwise 8}
    clStartRow       : Integer;   {first row number}
    calMargin        : Integer;

    {property methods}
    function GetDay: Integer;
    function GetMonth: Integer;
    function GetYear: Integer;
    procedure SetBorderStyle(Value: TBorderStyle);
    procedure SetDate(Value: TDateTime);
    procedure SetDateFormat(Value: TVpDateFormat);
    procedure SetDayNameWidth(Value: TVpDayNameWidth);
    procedure SetDisplayOptions(Value: TVpCalDisplayOptions);
    procedure SetDrawHeader(Value: Boolean);
    procedure SetWantDblClicks(Value: Boolean);
    procedure SetWeekStarts(Value: TVpDayType);

    {internal methods}
    procedure PopupToday(Sender: TObject);
    procedure PopupNextMonth(Sender: TObject);
    procedure PopupPrevMonth(Sender: TObject);
    procedure PopupNextYear(Sender: TObject);
    procedure PopupPrevYear(Sender: TObject);
    procedure InitializeDefaultPopup;
    procedure calChangeMonth(Sender: TObject);
    procedure calColorChange(Sender: TObject);
    function calGetCurrentRectangle: TRect;
      {-get bounding rectangle for the current calendar day}
    function calGetValidDate(ADate: TDateTime; Delta: Integer): TDateTime;
    procedure calRebuildCalArray(ADate: TDateTime);
      {-recalculate the contents of the calendar array}
    procedure CalculateSizes(WorkCanvas: TCanvas; Angle: TVpRotationAngle;
      Rect: TRect; out Row: TRowArray; out Col: TColArray; DisplayOnly: Boolean);
    procedure calRecalcSize (DisplayOnly: Boolean);
      {-calcualte new sizes for rows and columns}

    {VCL control methods}
    procedure CMEnter(var Msg: {$IFDEF DELPHI}TMessage{$ELSE}TLMessage{$ENDIF}); message CM_ENTER;
    procedure CMExit(var Msg: {$IFDEF DELPHI}TMessage{$ELSE}TLMessage{$ENDIF}); message CM_EXIT;
    procedure CMFontChanged(var Msg: {$IFDEF DELPHI}TMessage{$ELSE}TLMessage{$ENDIF}); message CM_FONTCHANGED;

    {windows message methods}
    {$IFDEF DELPHI}
    procedure WMEraseBkgnd(var Msg: TWMEraseBkgnd); message WM_ERASEBKGND;
    procedure WMGetDlgCode(var Msg: TWMGetDlgCode); message WM_GETDLGCODE;
    procedure WMKillFocus(var Msg: TWMKillFocus); message WM_KILLFOCUS;
    {$ELSE}
    procedure WMEraseBkgnd(var Msg: TLMEraseBkgnd); message LM_ERASEBKGND;
//    procedure WMGetDlgCode(var Msg: TLMGetDlgCode); message LM_GETDLGCODE;
    procedure WMKillFocus(var Msg: TLMKillFocus); message LM_KILLFOCUS;
    {$ENDIF}

    procedure calBtnClick(Sender: TObject);
    procedure CreateParams(var Params: TCreateParams); override;
    procedure CreateWnd; override;
    procedure DoOnChange(Value: TDateTime); dynamic;
    function DoOnGetDateEnabled(ADate: TDateTime): Boolean; dynamic;
   {$IFDEF LCL}
    function DoMouseWheel(Shift: TShiftState; Delta: Integer; MousePos: TPoint): Boolean; override;
   {$ELSE}
    procedure DoOnMouseWheel(Shift: TShiftState; Delta, XPos, YPos: SmallInt); override;
   {$ENDIF}
    function IsReadOnly: Boolean; dynamic;
      {-return true if the calendar is in read-only mode}
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    procedure KeyPress(var Key: Char); override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure Paint; override;

  public
    constructor Create(AOwner: TComponent); override;
    constructor CreateEx(AOwner: TComponent; AsPopup: Boolean); virtual;
    destructor Destroy; override;
    procedure LoadLanguage;

    procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;

    function GetControlType: TVpItemType; override;

    procedure IncDay(Delta: Integer);
    procedure IncMonth(Delta: Integer);
    procedure IncYear(Delta: Integer);

    procedure PaintToCanvas(ACanvas: TCanvas; ARect: TRect;
      Angle: TVpRotationAngle; ADate: TDateTime);
    procedure RenderToCanvas(RenderCanvas: TCanvas; RenderIn: TRect;
      Angle: TVpRotationAngle; Scale: Extended; RenderDate: TDateTime;
      StartLine: Integer; StopLine: Integer; UseGran: TVpGranularity;
      DisplayOnly: Boolean); override;
    procedure SetToday;

    { LinkHandler is the method which is called by the ControlLink component,  }
    { it is used to synchronize the calendar's date with other Visual PlanIt   }
    { controls do not call the LinkHandler procedure programatically.          }
    procedure LinkHandler(Sender: TComponent; NotificationType: TVpNotificationType;
      const Value: Variant); override;

    property Browsing : Boolean read FBrowsing;
    property Canvas;
    property Day: Integer read GetDay;
    property Month : Integer read GetMonth;
    property Year : Integer read GetYear;

    {properties}
    property Align;
    property Anchors;
   {$IFDEF LCL}
    property BorderSpacing;
   {$ENDIF}
    property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle;
    property Color;
    property Colors: TVpCalColors read FColors write FColors;
    property Date: TDateTime read FDate write SetDate;
    property DateFormat: TVpDateFormat read FDateFormat write SetDateFormat;
    property DayNameWidth: TVpDayNameWidth read FDayNameWidth write SetDayNameWidth;
    property Options: TVpCalDisplayOptions read FOptions write SetDisplayOptions;
    property ReadOnly: Boolean read FReadOnly write FReadOnly;
    property WantDblClicks: Boolean read FWantDblClicks write SetWantDblClicks;
    property WeekStarts: TVpDayType read FWeekStarts write SetWeekStarts;

    {events}
    property OnChange: TDateChangeEvent read  FOnChange write FOnChange;
    property OnDrawDate : TCalendarDateEvent read FOnDrawDate write FOnDrawDate;
    property OnDrawItem : TCalendarDateEvent read FOnDrawItem write FOnDrawItem;
    property OnGetDateEnabled : TGetDateEnabledEvent read FOnGetDateEnabled write FOnGetDateEnabled;
    property OnGetHighlight : TGetHighlightEvent read FOnGetHighlight write FOnGetHighlight;
  end;

  TVpCalendar = class(TVpCustomCalendar)
  published
    {properties}
    {$IFDEF VERSION4}
    property Anchors;
    property Constraints;
    property DragKind;
    {$ENDIF}
    property Align;
    {$IFDEF LCL}
    property BorderSpacing;
    {$ENDIF}
    property BorderStyle;
    property Color;
    property Colors;
    property Cursor;
    property DateFormat;
    property DayNameWidth;
    property DragCursor;
    property DragMode;
    property Enabled;
    property Font;
    property Options;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ReadOnly;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property Visible;
    property WantDblClicks;
    property WeekStarts;
    {events}
    property AfterEnter;
    property AfterExit;
    property OnChange;
    property OnClick;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnDrawDate;
    property OnDrawItem;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnGetDateEnabled;
    property OnGetHighlight;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnStartDrag;
  end;

implementation

uses
 {$IFDEF LCL}
  DateUtils,
 {$ENDIF}
  VpCalendarPainter;

const
  CAL_MARGIN = 4; {left, right, and top margin}

function SumOf(const A: array of Integer; First, Last: Integer): Integer;
var
  I : Integer;
begin
  Result := 0;
  for I := First to Last do
    Result := Result  + A[I];
end;

{*** TVpCalColors ***}
procedure TVpCalColors.Assign(Source: TPersistent);
begin
  if Source is TVpCalColors then begin
    FCalColors := TVpCalColors(Source).FCalColors;
    FColorScheme := TVpCalColors(Source).FColorScheme;
    FOnChange := TVpCalColors(Source).FOnChange;
  end else
    inherited Assign(Source);
end;
{=====}

procedure TVpCalColors.BeginUpdate;
begin
  FUpdating := True;
end;

procedure TVpCalColors.EndUpdate;
begin
  FUpdating := False;
  DoOnChange;
end;
{=====}

procedure TVpCalColors.DoOnChange;
begin
  if not FUpdating and Assigned(FOnChange) then
    FOnChange(Self);

  if not SettingScheme then
    FColorScheme := cscalCustom;
end;
{=====}

function TVpCalColors.GetColor(Index: Integer) : TColor;
begin
  Result := FCalColors[Index];
end;
{=====}

procedure TVpCalColors.SetColor(Index: Integer; Value: TColor);
begin
  if Value <> FCalColors[Index] then begin
    FCalColors[Index] := Value;
    DoOnChange;
  end;
end;
{=====}

procedure TVpCalColors.SetColorScheme(Value: TVpCalColorScheme);
begin
  if Value <> FColorScheme then begin
    SettingScheme := True;
    try
      FColorScheme := Value;
      if Value <> cscalCustom then begin
        FCalColors := CalScheme[Value];
        DoOnChange;
      end;
    finally
      SettingScheme := False;
    end;
  end;
end;
{=====}


{*** TVpCustomCalendar ***}
procedure TVpCustomCalendar.calBtnClick(Sender: TObject);
var
  Key: Word;
begin
  SetFocus;
  Key := 0;

  if Sender = clBtnLeft then begin
    Key := VK_PRIOR;
    KeyDown(Key, []);
  end else if Sender = clBtnRevert then begin
    Key := VK_ESCAPE;
    KeyDown(Key, []);
  end else if Sender = clBtnRight then begin
    Key := VK_NEXT;
    KeyDown(Key, []);
  end else if Sender = clBtnToday then begin
    Key := VK_BACK;
    KeyDown(Key, [ssAlt]);
  end else if Sender = clBtnNextYear then begin
    Key := VK_NEXT;
    KeyDown(Key, [ssCtrl]);
  end else if Sender = clBtnPrevYear then begin
    Key := VK_PRIOR;
    KeyDown(Key, [ssCtrl]);
  end;
end;
{=====}

procedure TVpCustomCalendar.calChangeMonth(Sender: TObject);
var
  Y, M, D: Word;
  MO: Integer;
  MI: TMenuItem;
begin
  MI := (Sender as TMenuItem);
  DecodeDate(FDate, Y, M, D);
  MO := MI.Tag;
  {set month and year}
  if (MO > M) and (MI.HelpContext < 3) then
    Dec(Y)
  else if (MO < M) and (MI.HelpContext > 3) then
    Inc(Y);
  M := M + MO;
  {set day}
  if D > DaysInAMonth(Y, MO) then
    D := DaysInAMonth(Y, MO);
  SetDate(calGetValidDate(EncodeDate(Y, MO, D)-1, +1));
  if (Assigned(FOnChange)) then
    FOnChange(Self, FDate);
end;
{=====}

procedure TVpCustomCalendar.calColorChange(Sender: TObject);
begin
  Invalidate;
end;
{=====}

function TVpCustomCalendar.calGetCurrentRectangle: TRect;
  {-get bounding rectangle for the current date}
var
  Idx : Integer;
  R, C: Integer;
begin
  {index into the month grid}
  Idx := clFirst + Pred(clDay) + 13;
  R := (Idx div 7);
  C := (Idx mod 7);
  Result := clRowCol[R,C];
end;
{=====}

function TVpCustomCalendar.calGetValidDate(ADate: TDateTime;
  Delta: Integer): TDateTime;
var
  I, X: Integer;
  Valid: Boolean;
  Fwd: Boolean;
begin
  Valid := false;
  Fwd := false;
  X := Delta;
  I := 1;
  while not Valid and (I < 1000) do begin
    {If the date is valid then yay!}
    if (DoOnGetDateEnabled(ADate + (X * I))) then begin
      Valid := true;
      Fwd := True;
    end
    {otherwise check the other direction}
    else if (DoOnGetDateEnabled(ADate - (X * I))) then begin
      valid := true;
    end
    else Inc(I);
  end;
  if Valid then
    if Fwd then Result := ADate + (X * I)
    else Result := ADate - (X * I)
  else
    raise(EVpCalendarError.Create(RSInvalidDate));
end;
{=====}

procedure TVpCustomCalendar.calRebuildCalArray(ADate: TDateTime);
var
  Day1: TVpDayType;
  I, J: Integer;
begin
  HandleNeeded;
  DecodeDate(ADate, clYear, clMonth, clDay);

  {get the first day of the current month and year}
  Day1 := TVpDayType(SysUtils.DayOfWeek(EncodeDate(clYear, clMonth, 1)) -1);

  {find its index}
  I := Byte(Day1) - Byte(WeekStarts) + 1;
  if I < 1 then
    Inc(I, 7);
  clFirst := I;

  {find the index of the last day in the month}
  clLast := clFirst + DaysInAMonth(clYear, clMonth) {%H-}- 1;

  {initialize the first part of the calendar}
  if clMonth = 1 then
    J := DaysInAMonth(clYear - 1, 12)
  else
    J := DaysInAMonth(clYear, clMonth-1);
  for I := clFirst-1 downto 1 do begin
    clCalendar[I] := J;
    Dec(J);
  end;

  {initialize the rest of the calendar}
  J := 1;
  for I := clFirst to 49 do begin
    clCalendar[I] := J;
    if I = clLast then
      J := 1
    else
      Inc(J);
  end;
end;
{=====}

procedure TVpCustomCalendar.CalculateSizes(WorkCanvas: TCanvas;
  Angle: TVpRotationAngle; Rect: TRect; out Row: TRowArray; out Col: TColArray;
  DisplayOnly: Boolean);
  {-calcualte new sizes for rows and columns}
var
  R: Integer;
  C: Integer;
  D1: Integer;
  D2: Integer;
  CH: Integer;
  RH: Integer;
  LR: Integer;

begin
  if (Angle = ra90) or (Angle = ra270) then
    clWidth := Rect.Bottom - Rect.Top - 2*calMargin
  else
    clWidth := Rect.Right - Rect.Left - 2*calMargin;

  {store row and column sizes}
  for C := 0 to 6 do
    Col[C] := clWidth div 7;

  if (FDrawHeader) then begin
    {button and date row}
    Row[0] := Round(1.4 * WorkCanvas.TextHeight('Yy'));
    {day name row}
    Row[1] := Round(1.5 * WorkCanvas.TextHeight('Yy'))
  end else begin
    {button and date row}
    Row[0] := Round(1.3 * WorkCanvas.TextHeight('Yy'));
    {day name row}
    Row[1] := 0;
  end;

  if (Angle = ra90) or (Angle = ra270) then
    CH := Rect.Right - Rect.Left - 2*calMargin - Row[0] - Row[1]
  else
    CH := Rect.Bottom - Rect.Top - 2*calMargin - Row[0] - Row[1];
  if ((not (cdoShowRevert in Options)) and (not (cdoShowToday in Options))) or
     DisplayOnly
  then
    LR := 7
  else
    LR := 8;

  RH := CH div (LR - 1);

  for R := 2 to 8 do
    Row[R] := RH;

  {distribute any odd horizontal space equally among the columns}
  for C := 0 to clWidth mod 7 do
    Inc(Col[C]);

  {distribute odd vertical space to top 2 rows}
  D1 := 0;
  for R := 0 to LR do
    D1 := D1 + Row[R];
  if (Angle = ra90) or (Angle = ra270) then
    D1 := Rect.Right - Rect.Left - D1 - 2*calMargin
  else
    D1 := Rect.Bottom - Rect.Top - D1 - 2*calMargin;
  D2 := D1 div 2;
  D1 := D1 - D2;
  Row[0] := Row[0] + D1;
  if (FDrawHeader) then
    Row[1] := Row[1] + D2;

  {initialize each cells TRect structure using}
  {the row heights from the Row[] array and the}
  {column widths from the Col[] array}
  for R := clStartRow to 7 do begin
    for C := 0 to 6 do begin
      clRowCol[R, C].Left := SumOf(Col, 0, C-1) + calMargin;
      clRowCol[R, C].Right := SumOf(Col, 0, C) + calMargin;
      clRowCol[R, C].Top := SumOf(Row, 0, R-1) + calMargin;
      clRowCol[R, C].Bottom := SumOf(Row, 0, R) + calMargin;
    end;
  end;
end;

procedure TVpCustomCalendar.calRecalcSize(DisplayOnly: Boolean);
  {-calcualte new sizes for rows and columns}
var
  Row: TRowArray;
  Col: TColArray;

begin
  if not HandleAllocated then
    Exit;

  {clear row/col position structure}
  FillChar(clRowCol, SizeOf(clRowCol), #0);

  {set the way the buttons should look}
  clBtnLeft.Flat     := {not Ctl3D and} not clPopup;
  clBtnRevert.Flat   := {not Ctl3D and} not clPopup;
  clBtnRight.Flat    := {not Ctl3D and} not clPopup;
  clBtnToday.Flat    := {not Ctl3D and} not clPopup;
  clBtnNextYear.Flat := {not Ctl3D and} not clPopup;
  clBtnPrevYear.Flat := {not Ctl3D and} not clPopup;

  clBtnRevert.Visible := cdoShowRevert in FOptions;
  clBtnToday.Visible := cdoShowToday in FOptions;
  clBtnLeft.Visible := (cdoShowNavBtns in FOptions);
  clBtnRight.Visible := (cdoShowNavBtns in FOptions);
  clBtnNextYear.Visible := (cdoShowNavBtns in FOptions);
  clBtnPrevYear.Visible := (cdoShowNavBtns in FOptions);

  CalculateSizes(Canvas, ra0, Rect (0, 0, Width, Height), Row, Col, DisplayOnly);

  {position and size the left and right month buttons}
  {position and size the next and prev year buttons}
  clBtnNextYear.Height := Row[0] - calMargin;
  clBtnNextYear.Width := Col[1] - calMargin;
  if clBtnNextYear.Width < clBtnNextYear.Glyph.Width + 3 then
    clBtnNextYear.Width := clBtnNextYear.Glyph.Width + 3;
  clBtnNextYear.Top := calMargin;
  clBtnNextYear.Left := ClientWidth - calMargin - clBtnNextYear.Width;

  clBtnPrevYear.Height := Row[0] - calMargin;
  clBtnPrevYear.Width := Col[5] - calMargin;
  if clBtnPrevYear.Width < clBtnPrevYear.Glyph.Width + 3 then
    clBtnPrevYear.Width := clBtnPrevYear.Glyph.Width + 3;
  clBtnPrevYear.Top := calMargin;
  clBtnPrevYear.Left := calMargin;

  clBtnLeft.Height := Row[0] - calMargin;
  clBtnLeft.Width := Col[0] - calMargin;
  if clBtnLeft.Width < clBtnLeft.Glyph.Width + 3 then
    clBtnLeft.Width := clBtnLeft.Glyph.Width + 3;
  clBtnLeft.Top := calMargin;
  clBtnLeft.Left := clBtnPrevYear.Left + clBtnPrevYear.Width;

  clBtnRight.Height := Row[0] - calMargin;
  clBtnRight.Width := Col[6] - calMargin;
  if clBtnRight.Width < clBtnRight.Glyph.Width + 3 then
    clBtnRight.Width := clBtnRight.Glyph.Width + 3;
  clBtnRight.Top := calMargin;
  clBtnRight.Left := clBtnNextYear.Left - clBtnRight.Width;

  {position and size "today" button}
  clBtnToday.Height := Row[8];
  clBtnToday.Width := Col[5] + Col[6] - calMargin;
  clBtnToday.Top := ClientHeight - calMargin - clBtnToday.Height + 1;
  clBtnToday.Left := ClientWidth - calMargin - clBtnToday.Width;

  {position and size "revert" button}
  clBtnRevert.Height := Row[8];
  clBtnRevert.Width := Col[5] + Col[6] - calMargin;
  clBtnRevert.Top := ClientHeight - calMargin - clBtnRevert.Height + 1;
  clBtnRevert.Left := clBtnToday.Left - clBtnRevert.Width - calMargin;
end;
{=====}

procedure TVpCustomCalendar.CMEnter(var Msg: {$IFDEF DELPHI}TMessage{$ELSE}TLMessage{$ENDIF});
var
  R : TRect;
begin
  inherited;

  clRevertDate := FDate;

  {invalidate the active date to ensure that the focus rect is painted}
  R := calGetCurrentRectangle;
  InvalidateRect(Handle, @R, False);
end;
{=====}

procedure TVpCustomCalendar.CMExit(var Msg: {$IFDEF DELPHI}TMessage{$ELSE}TLMessage{$ENDIF});
var
  R : TRect;
begin
  inherited;

  {invalidate the active date to ensure that the focus rect is painted}
  R := calGetCurrentRectangle;
  InvalidateRect(Handle, @R, False);
end;
{=====}

procedure TVpCustomCalendar.CMFontChanged(var Msg: {$IFDEF DELPHI}TMessage{$ELSE}TLMessage{$ENDIF});
begin
  inherited;

  if csLoading in ComponentState then
    Exit;

  calRecalcSize(False);
  Invalidate;
end;
{=====}

constructor TVpCustomCalendar.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);

  ControlStyle := ControlStyle + [csClickEvents, csFramed] - [csCaptureMouse];

  Height := 140;
  TabStop := True;
  Width := 200;

  calMargin := ScaleX(CAL_MARGIN, DesignTimeDPI);

 {$IFNDEF LCL}
  Font.Name := 'MS Sans Serif';
  Font.Size := 8;
 {$ENDIF}

  FBorderStyle := bsNone;
  FDayNameWidth  := 3;
  FDateFormat := dfLong;
  FOptions := [cdoShortNames, cdoShowYear, cdoShowRevert, cdoShowToday,
               cdoShowNavBtns, cdoHighlightSun, cdoHighlightSat];
  FWantDblClicks := True;
  FWeekStarts := dtSunday;
  FLastRenderX := 0;
  FLastRenderY := 0;

  clInLinkHandler := false;

  {create navigation buttons}
  clBtnLeft := TSpeedButton.Create(Self);
  clBtnLeft.Parent := Self;
  {$IFDEF NEW_ICONS}
  LoadGlyphFromRCDATA(clBtnLeft.Glyph, 'VpLArrow', 16, 24, 32);
  {$ELSE}
  clBtnLeft.Glyph.LoadFromResourceName(HINSTANCE,'VPLEFTARROW'); //soner geändert: clBtnLeft.Glyph.Handle := LoadBaseBitmap('VPLEFTARROW');
  {$ENDIF}
  clBtnLeft.OnClick := calBtnClick;
  clBtnLeft.Hint := RSPrevMonth;
  clBtnLeft.ShowHint := True;

  clBtnRight := TSpeedButton.Create(Self);
  clBtnRight.Parent := Self;
  {$IFDEF NEW_ICONS}
  LoadGlyphFromRCDATA(clBtnRight.Glyph, 'VpRArrow', 16, 24, 32);
  {$ELSE}
  clBtnRight.Glyph.LoadFromResourceName(HINSTANCE,'VPRIGHTARROW'); //soner geändert: clBtnRight.Glyph.Handle := LoadBaseBitmap('VPRIGHTARROW');
  {$ENDIF}
  clBtnRight.OnClick := calBtnClick;
  clBtnRight.Hint := RSNextMonth;
  clBtnRight.ShowHint := True;

  clBtnNextYear := TSpeedButton.Create(Self);
  clBtnNextYear.Parent := Self;
  {$IFDEF NEW_ICONS}
  LoadGlyphFromRCDATA(clBtnNextYear.Glyph, 'VpRArrows', 16, 24, 32);
  {$ELSE}
  clBtnNextYear.Glyph.LoadFromResourceName(HINSTANCE,'VPRIGHTARROWS'); //soner geöndert: clBtnNextYear.Glyph.Handle := LoadBaseBitmap('VPRIGHTARROWS');
  {$ENDIF}
  clBtnNextYear.OnClick := calBtnClick;
  clBtnNextYear.Hint := RSNextYear;
  clBtnNextYear.ShowHint := True;

  clBtnPrevYear := TSpeedButton.Create(Self);
  clBtnPrevYear.Parent := Self;
  {$IFDEF NEW_ICONS}
  LoadGlyphFromRCData(clBtnPrevYear.Glyph, 'VpLArrows', 16, 24, 32);
  {$ELSE}
  clBtnPrevYear.Glyph.LoadFromResourceName(HINSTANCE,'VPLEFTARROWS'); //soner geöndert: clBtnPrevYear.Glyph.Handle := LoadBaseBitmap('VPLEFTARROWS');
  {$ENDIF}
  clBtnPrevYear.OnClick := calBtnClick;
  clBtnPrevYear.Hint := RSPrevYear;
  clBtnPrevYear.ShowHint := True;

  {create "revert" button}
  clBtnRevert := TSpeedButton.Create(Self);
  clBtnRevert.Parent := Self;
  {$IFDEF NEW_ICONS}
  LoadGlyphFromRCData(clBtnRevert.Glyph, 'VpRevert', 16, 24, 32);
  {$ELSE}
  clBtnRevert.Glyph.LoadFromResourceName(HINSTANCE,'VPREVERT'); //soner geändert: clBtnRevert.Glyph.Handle := LoadBaseBitmap('VPREVERT');
  {$ENDIF}
  clBtnRevert.OnClick := calBtnClick;
  clBtnRevert.Hint := RSCalendarRevert;
  clBtnRevert.ShowHint := True;

  {create "today" button}
  clBtnToday := TSpeedButton.Create(Self);
  clBtnToday.Parent := Self;
  {$IFDEF NEW_ICONS}
  LoadGlyphFromRCData(clBtnToday.Glyph, 'VpToday', 16, 24, 32);
  {$ELSE}
  clBtnToday.Glyph.LoadFromResourceName(HINSTANCE,'VPTODAY'); //soner geändert: clBtnToday.Glyph.Handle := LoadBaseBitmap('VPTODAY');
  {$ENDIF}
  clBtnToday.OnClick := calBtnClick;
  clBtnToday.Hint := RSToday;
  clBtnToday.ShowHint := True;

  {assign default color scheme}
  FColors := TVpCalColors.Create;
  FColors.OnChange := calColorChange;
  FColors.FCalColors := CalScheme[cscalWindows];

  {assign default international support object}

  FDrawHeader:= True;
  clRowCount := 8;
  clStartRow := 0;

  FDefaultPopup := TPopupMenu.Create (Self);
  InitializeDefaultPopup;
end;
{=====}

constructor TVpCustomCalendar.CreateEx(AOwner: TComponent; AsPopup: Boolean);
begin
  clPopup := AsPopup;
  Create(AOwner);
end;
{=====}

procedure TVpCustomCalendar.CreateParams(var Params: TCreateParams);
{$IFNDEF LCL}
const
  BorderStyles: array[TBorderStyle] of LongInt = (0, WS_BORDER);
{$ENDIF}
begin
  inherited CreateParams(Params);
{$IFNDEF LCL}
  with Params do begin
    Style := LongInt(Style) or BorderStyles[FBorderStyle];
    if clPopup then begin
      WindowClass.Style := WindowClass.Style or CS_SAVEBITS;
    end;
  end;
{$ENDIF}
  if NewStyleControls and ({Ctl3D or }clPopup) and (FBorderStyle = bsSingle) then begin
    if not clPopup then
      Params.Style := Params.Style and not WS_BORDER;
    Params.ExStyle := Params.ExStyle or WS_EX_CLIENTEDGE;
  end;

  {set style to reflect desire for double clicks}
  if FWantDblClicks then
    ControlStyle := ControlStyle + [csDoubleClicks]
  else
    ControlStyle := ControlStyle - [csDoubleClicks];
end;
{=====}

procedure TVpCustomCalendar.CreateWnd;
begin
  inherited CreateWnd;

  calRecalcSize(False);

  {if not set, get current date}
  if FDate = 0 then
    SetDate(calGetValidDate(SysUtils.Date-1, +1));
end;
{=====}

destructor TVpCustomCalendar.Destroy;
begin
  FColors.Free;
  FColors := nil;

  FDefaultPopup.Free;

  inherited Destroy;
end;
{=====}

procedure TVpCustomCalendar.DoOnChange(Value: TDateTime);
begin
  if Assigned(FOnChange) then
    FOnChange(Self, Value);
end;
{=====}

function TVpCustomCalendar.DoOnGetDateEnabled(ADate: TDateTime) : Boolean;
begin
  Result := True;
  if Assigned(FOnGetDateEnabled) then
    FOnGetDateEnabled(Self, ADate, Result);
end;
{=====}

{$IFDEF LCL}
function TVpCustomCalendar.DoMouseWheel(Shift: TShiftState;
  Delta: Integer; MousePos: TPoint): Boolean;
{$ELSE}
procedure TVpCustomCalendar.DoMouseWheel(Shift: TShiftState;
  Delta, XPos, YPos: SmallInt);
{$ENDIF}
const
  WHEEL_DELTA = 120;  // in unit Windows.
var
  key: Word;
begin
 {$IFDEF LCL}
  Result := inherited DoMouseWheel(Shift, Delta, MousePos);
 {$ELSE}
  inherited DoOnMouseWheel(Shift, Delta, XPos, YPos);
 {$ENDIF}
  if Abs(Delta) = WHEEL_DELTA then begin
    {inc/dec month}
    if Delta < 0 then
      Key := VK_NEXT
    else
      Key := VK_PRIOR;
    KeyDown(Key, []);
  end else if Abs(Delta) > WHEEL_DELTA then begin
    {inc/dec year}
    if Delta < 0 then
      Key := VK_NEXT
    else
      Key := VK_PRIOR;
    KeyDown(Key, [ssCtrl]);
  end else if Abs(Delta) < WHEEL_DELTA then begin
    {inc/dec Week}
    if Delta < 0 then
      Key := VK_DOWN
    else
      Key := VK_UP;
    KeyDown(Key, []);
  end;
end;
{=====}

function TVpCustomCalendar.IsReadOnly: Boolean;
begin
  Result := ReadOnly;
end;
{=====}

procedure TVpCustomCalendar.KeyDown(var Key: Word; Shift: TShiftState);
var
  Y: Word;
  M: Word;
  D: Word;
  HD: TDateTime;
  PopupPoint: TPoint;

begin
  inherited KeyDown(Key, Shift);

  if IsReadOnly then
    Exit;

  HD := FDate;
  case Key of
    VK_LEFT:
      if Shift = [] then
        SetDate(calGetValidDate(FDate, -1))
      else if ssCtrl in Shift then
        IncMonth (-1)
      else if ssShift in Shift then
        IncYear (-1);

    VK_RIGHT:
      if Shift = [] then
        SetDate(calGetValidDate(FDate, +1))
      else if ssCtrl in Shift then
        IncMonth (1)
      else if ssShift in Shift then
        IncYear (1);

    VK_UP:
      if Shift = [] then
        SetDate(calGetValidDate(FDate, -7))
      else if ssCtrl in Shift then
        IncYear (-1)
      else if ssShift in Shift then
        IncMonth (-1);

    VK_DOWN:
      if Shift = [] then
        SetDate(calGetValidDate(FDate, +7))
      else if ssCtrl in Shift then
        IncYear (1)
      else if ssShift in Shift then
        IncMonth (1);

    VK_HOME:
      if ssCtrl in Shift then begin
        DecodeDate(FDate, Y, M, D);
        SetDate(calGetValidDate(EncodeDate(Y, 1, 1)-1, +1));
      end else if Shift = [] then begin
        DecodeDate(FDate, Y, M, D);
        SetDate(calGetValidDate(EncodeDate(Y, M, 1)-1, +1));
      end;

    VK_END:
      if ssCtrl in Shift then begin
        DecodeDate(FDate, Y, M, D);
        SetDate(calGetValidDate(EncodeDate(Y, 12, DaysInAMonth(Y, 12))+1, -1));
      end else if Shift = [] then begin
        DecodeDate(FDate, Y, M, D);
        SetDate(calGetValidDate(EncodeDate(Y, M, DaysInAMonth(Y, M))+1, -1));
      end;

    VK_PRIOR:
      if ssCtrl in Shift then begin
        IncYear(-1);
      end else if Shift = [] then begin
        IncMonth(-1);
      end;

    VK_NEXT:
      if ssCtrl in Shift then begin
        IncYear(1);
      end else if Shift = [] then begin
        IncMonth(1);
      end;

    VK_BACK:
      if ssAlt in Shift then
        SetDate(calGetValidDate(SysUtils.Date-1, +1));

    VK_ESCAPE:
      if Shift = [] then
        SetDate(calGetValidDate(clRevertDate-1, +1));

    VK_F10:
      if (ssShift in Shift) and not (Assigned (PopupMenu)) then begin
        PopupPoint := GetClientOrigin;
        FDefaultPopup.Popup (PopupPoint.x + 10, PopupPoint.y + 10);
      end;

    VK_APPS:
      if not Assigned (PopupMenu) then begin
        PopupPoint := GetClientOrigin;
        FDefaultPopup.Popup (PopupPoint.x + 10, PopupPoint.y + 10);
      end;
  end;

  if HD <> FDate then begin
      FBrowsing := True;
    try
      DoOnChange(FDate);
    finally
      FBrowsing := False;
    end;
  end;
end;
{=====}

procedure TVpCustomCalendar.KeyPress(var Key: Char);
begin
  inherited KeyPress(Key);

  if IsReadOnly then
    Exit;

  case Key of
    '+' : SetDate(calGetValidDate(FDate, +1));
    '-' : SetDate(calGetValidDate(FDate, -1));
    #13 : DoOnChange(FDate);       {date selected}
    #32 : DoOnChange(FDate);       {date selected}
    ^Z  : SetDate(calGetValidDate(SysUtils.Date-1, +1));
  end;
end;
{=====}

procedure TVpCustomCalendar.MouseDown(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
var
  Yr, M, D: Word;
  Yr2, M2, D2: Word;
  R, C: Integer;
  OldIdx, NewIdx: Integer;
  Re: TRect;
  Ignore: Boolean;
  ClientOrigin: TPoint;

begin
  inherited;

  if (not Assigned (PopupMenu)) and (Button = mbRight) then begin
    if not focused then
      SetFocus;
    ClientOrigin := GetClientOrigin;
    FDefaultPopup.Popup (X + ClientOrigin.x, Y + ClientOrigin.y);
    Exit;
  end;

  {exit if this click happens when the popup menu is active}
  if clInPopup or (not Visible) then 
    Exit;

  SetFocus;

  inherited MouseDown(Button, Shift, X, Y);

  if IsReadOnly then
    Exit;

  {if we have the mouse captured, see if a button was clicked}
  if GetCapture = Handle then begin
    if (cdoShowNavBtns in Options) then begin
      Re := clBtnLeft.ClientRect;
      Re.TopLeft := ScreenToClient(clBtnLeft.ClientToScreen(Re.TopLeft));
      Re.BottomRight := ScreenToClient(clBtnLeft.ClientToScreen(Re.BottomRight));
      if PtInRect(Re, Point(X, Y)) then begin
        clBtnLeft.Click;
        Exit;
      end;

      Re := clBtnRight.ClientRect;
      Re.TopLeft := ScreenToClient(clBtnRight.ClientToScreen(Re.TopLeft));
      Re.BottomRight := ScreenToClient(clBtnRight.ClientToScreen(Re.BottomRight));
      if PtInRect(Re, Point(X, Y)) then begin
        clBtnRight.Click;
        Exit;
      end;

      Re := clBtnNextYear.ClientRect;
      Re.TopLeft := ScreenToClient(clBtnNextYear.ClientToScreen(Re.TopLeft));
      Re.BottomRight := ScreenToClient(clBtnNextYear.ClientToScreen(Re.BottomRight));
      if PtInRect(Re, Point(X, Y)) then begin
        clBtnNextYear.Click;
        Exit;
      end;

      Re := clBtnPrevYear.ClientRect;
      Re.TopLeft := ScreenToClient(clBtnPrevYear.ClientToScreen(Re.TopLeft));
      Re.BottomRight := ScreenToClient(clBtnPrevYear.ClientToScreen(Re.BottomRight));
      if PtInRect(Re, Point(X, Y)) then begin
        clBtnPrevYear.Click;
        Exit;
      end;
    end;

    if (cdoShowRevert in Options) then begin
      Re := clBtnRevert.ClientRect;
      Re.TopLeft := ScreenToClient(clBtnRevert.ClientToScreen(Re.TopLeft));
      Re.BottomRight := ScreenToClient(clBtnRevert.ClientToScreen(Re.BottomRight));
      if PtInRect(Re, Point(X, Y)) then begin
        clBtnRevert.Click;
        Exit;
      end;
    end;

    if (cdoShowToday in Options) then begin
      Re := clBtnToday.ClientRect;
      Re.TopLeft := ScreenToClient(clBtnToday.ClientToScreen(Re.TopLeft));
      Re.BottomRight := ScreenToClient(clBtnToday.ClientToScreen(Re.BottomRight));
      if PtInRect(Re, Point(X, Y)) then begin
        clBtnToday.Click;
        Exit;
      end;
    end;
  end;

  {save current date}
  DecodeDate(FDate, Yr, M, D);
  M2 := M;

  {calculate the row and column clicked on}
  for R := 2 to 8 do begin
    for C := 0 to 6 do begin
      if PtInRect(clRowCol[R,C], Point(X, Y)) then begin
        {convert to an index}
        NewIdx := ((R-2) * 7) + Succ(C);
        OldIdx := clFirst + Pred(clDay);
        Ignore := False;

        if NewIdx <> OldIdx then begin
          {see if this date is disabled - selection not allowed}
          if not DoOnGetDateEnabled(FDate+(NewIdx-OldIdx)) then
            Break;
          DecodeDate(FDate+(NewIdx-OldIdx), Yr2, M2, D2);
          if not (cdoShowInactive in FOptions) then begin
            {will this change the month?}
            if M2 <> M then
              Ignore := True;
          end;
          {convert to a date and redraw}
          if not Ignore then
            SetDate(FDate+(NewIdx-OldIdx));
        end;

        if (not Ignore) and (Button = mbLeft) then begin
          if M2 <> M then begin
              FBrowsing := True;
            try
              DoOnChange(FDate);
            finally
              FBrowsing := False;
            end;
          end else
            DoOnChange(FDate);
        end;

        Break;
      end;
    end;
  end;
end;
{=====}

procedure TVpCustomCalendar.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
  P: TPoint;
  M: TPopUpMenu;
  MI: TMenuItem;
  I: Integer;
  J: Integer;
  K: Integer;
  MO: Integer;
  YR: Word;
  MM: Word;
  DA: Word;
  HC: Boolean;
begin
  inherited MouseUp(Button, Shift, X, Y);

  if (PopUpMenu = nil) and (Button = mbRight) and
     (Y < clRowCol[1,0].Top) {above day names} and
     (X > clBtnPrevYear.Left + clBtnNextYear.Width) and (X < clBtnNextYear.Left)
  then begin
    if not Focused and CanFocus then
      SetFocus;

    M := TPopupMenu.Create(Self);
    try
      DecodeDate(FDate, YR, MM, DA);
      MO := MM; {convert to integer to avoid wrap-around errors with words}

      {determine the starting month}
      I := MO - 3;
      if I < 1 then
        I := MO - 3 + 12;

      {determine the ending month + 1}
      J := MO + 4;
      if J > 12 then
        J := MO + 4 - 12;

      K := 0;
      {create the menu items}
      repeat
        MI := TMenuItem.Create(M);
        MI.Caption := FormatSettings.LongMonthNames[I];
        MI.Enabled := Enabled;
        MI.OnClick := calChangeMonth;
        MI.Tag := I;
        MI.HelpContext := K;
        M.Items.Add(MI);
        Inc(I);
        Inc(K);
        if I > 12 then
          I := 1;
      until I = J;

      HC := GetCapture = Handle;

      P.X := X-20;
      P.Y := Y - (GetSystemMetrics(SM_CYMENU)*7) div 2;
      P := ClientToScreen(P);
      {move the mouse to cause the menu item to highlight}
      {$IFDEF DELPHI}
      PostMessage(Handle, WM_MOUSEMOVE, 0, MAKELONG(P.X,P.Y+1));
      {$ELSE}
      PostMessage(Handle, LM_MOUSEMOVE, 0, MAKELONG(P.X,P.Y+1));
      {$ENDIF}

      clInPopup := True;
      try
        M.PopUp(P.X, P.Y);

        Application.ProcessMessages;

        {capture the mouse again}
        if clPopup and HC then
          SetCapture(Handle);
      finally
        clInPopup := false;
      end;
    finally
      M.Free;
    end;
  end;
end;
{=====}

procedure TVpCustomCalendar.IncDay(Delta: Integer);
  {-change the day by Delta (signed) days}
begin
  if Delta > 0 then
    SetDate(calGetValidDate(FDate+Delta-1, +1))
  else
    SetDate(calGetValidDate(FDate+Delta+1, -1));
end;
{=====}

procedure TVpCustomCalendar.IncMonth(Delta: Integer);
  {-change the month by Delta (signed) months}
var
  Y, M, D: Word;
  iY, iM, iD: Integer;
begin
  DecodeDate(FDate, Y, M, D);
  iY := Y; iM := M; iD := D;
  Inc(iM, Delta);
  if iM > 12 then begin
    iM := iM - 12;
    Inc(iY);
  end else if iM < 1 then begin
    iM := iM + 12;
    Dec(iY);
  end;
  if iD > DaysInAMonth(iY, iM) then
    iD := DaysInAMonth(iY, iM);

  SetDate(calGetValidDate(EncodeDate(iY, iM, iD)-1, +1));
end;
{=====}

procedure TVpCustomCalendar.IncYear(Delta: Integer);
var
  Y, M, D  : Word;
  iY, iM, iD : Integer;
begin
  DecodeDate(FDate, Y, M, D);
  iY := Y; iM := M; iD := D;
  Inc(iY, Delta);
  if iD > DaysInAMonth(iY, iM) then
    iD := DaysInAMonth(iY, iM);
  SetDate(calGetValidDate(EncodeDate(iY, iM, iD)-1, +1));
end;
{=====}

procedure TVpCustomCalendar.Paint;
begin
  RenderToCanvas(
    Canvas,                      // Paint Canvas
    Rect (0, 0, Width, Height),  // Paint Rectangle
    ra0,
    1,                           // Scale
    Date,                        // Date
    -1,                          // Start At
    -1,                          // End At
    gr30Min,
    False);                      // Display Only
end;
{=====}

procedure TVpCustomCalendar.LinkHandler(Sender: TComponent;
  NotificationType: TVpNotificationType; const Value: Variant);
begin
  clInLinkHandler := true;
  try
    if NotificationType = neDateChange then
      Date := Value
    else if NotificationType = neInvalidate then
      Invalidate;
  finally
    clInLinkHandler := false;
  end;
end;
{=====}

function TVpCustomCalendar.GetDay: Integer;
begin
  Result := clDay;
end;
{=====}

function TVpCustomCalendar.GetMonth: Integer;
begin
  Result := clMonth;
end;
{=====}

function TVpCustomCalendar.GetYear: Integer;
begin
  Result := clYear;
end;
{=====}

function TVpCustomCalendar.GetControlType: TVpItemType;
begin
  Result := itCalendar;
end;

procedure TVpCustomCalendar.LoadLanguage;
begin
  FDefaultPopup.Items.Clear;
  InitializeDefaultPopup;
end;

procedure TVpCustomCalendar.PaintToCanvas(ACanvas: TCanvas; ARect: TRect;
  Angle: TVpRotationAngle; ADate: TDateTime);
begin
  RenderToCanvas(ACanvas, ARect, Angle, 1, ADate, -1, -1, gr30Min, True);
end;

procedure TVpCustomCalendar.RenderToCanvas(RenderCanvas: TCanvas;
  RenderIn: TRect; Angle: TVpRotationAngle; Scale: Extended;
  RenderDate: TDateTime; StartLine: Integer; StopLine: Integer;
  UseGran: TVpGranularity; DisplayOnly: Boolean);
var
  painter: TVpCalendarPainter;
begin
  painter := TVpCalendarPainter.Create(Self, RenderCanvas);
  try
    painter.RenderToCanvas(RenderIn, Angle, Scale, RenderDate,
      StartLine, StopLine, UseGran, DisplayOnly);
  finally
    painter.Free;
  end;
end;

procedure TVpCustomCalendar.SetBorderStyle(Value: TBorderStyle);
begin
  if Value <> FBorderStyle then begin
    FBorderStyle := Value;
    RecreateWnd(Self); { *Converted from RecreateWnd* }
  end;
end;
{=====}

procedure TVpCustomCalendar.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
begin
  inherited SetBounds(ALeft, ATop, AWidth, AHeight);
  if csLoading in ComponentState then
    Exit;
  calRecalcSize (False);
end;
{=====}

procedure TVpCustomCalendar.SetDate(Value: TDateTime);
var
  R: TRect;
  Y: Word;
  M: Word;
  D: Word;
begin
  if Value <> FDate then begin
    {determine if the new date is in the same month}
    DecodeDate(Value, Y, M, D);
    if (clYear = Y) and (clMonth = M) then begin
      {invalidate the old date}
      R := calGetCurrentRectangle;
      InvalidateRect(Handle, @R, False);
    end else
      Invalidate;

    DecodeDate(Value, clYear, clMonth, clDay);
    FDate := Value;
    calRebuildCalArray (FDate);

    {invalidate the new date}
    R := calGetCurrentRectangle;
    InvalidateRect(Handle, @R, False);

    if (not clInLinkHandler) and (ControlLink <> nil) then
      ControlLink.Notify(self, neDateChange, Date);
  end;
end;
{=====}

procedure TVpCustomCalendar.SetDateFormat(Value: TVpDateFormat);
begin
  if Value <> FDateFormat then begin
   FDateFormat := Value;
   Invalidate;
  end;
end;
{=====}

procedure TVpCustomCalendar.SetDayNameWidth(Value: TVpDayNameWidth);
begin
  if Value <> FDayNameWidth then begin
   FDayNameWidth := Value;
   Invalidate;
  end;
end;
{=====}

procedure TVpCustomCalendar.SetDisplayOptions(Value: TVpCalDisplayOptions);
begin
  if Value <> FOptions then begin
    FOptions := Value;
    if csDesigning in ComponentState then begin
      if cdoShowRevert in Options then
        clBtnRevert.Parent := Self
      else
        clBtnRevert.Parent := nil;
      if cdoShowToday in Options then
        clBtnToday.Parent := Self
      else
        clBtnToday.Parent := nil;
      if cdoShowNavBtns in Options then begin
        clBtnLeft.Parent := Self;
        clBtnRight.Parent := Self;
        clBtnNextYear.Parent := Self;
        clBtnPrevYear.Parent := Self;
      end else begin
        clBtnLeft.Parent := nil;
        clBtnRight.Parent := nil;
        clBtnNextYear.Parent := nil;
        clBtnPrevYear.Parent := nil;
      end;
    end;
    calRecalcSize (False);
    Invalidate;
  end;
end;
{=====}

procedure TVpCustomCalendar.SetDrawHeader(Value: Boolean);
  {-set the DrawHeader property value}
begin
  if Value <> FDrawHeader then begin
    FDrawHeader := Value;
    if FDrawHeader then begin
      clStartRow := 0;
      clRowCount := 8;
    end else begin
      clStartRow := 2;
      clRowCount := 7;
    end;
    calRecalcSize (False);
    Refresh;
  end;
end;
{=====}

procedure TVpCustomCalendar.SetToday;
  {-set the calendar to todays date}
begin
  Date := Now;
end;
{=====}

procedure TVpCustomCalendar.SetWantDblClicks(Value: Boolean);
begin
  if Value <> FWantDblClicks then begin
    FWantDblClicks := Value;
    RecreateWnd(Self); { *Converted from RecreateWnd* }
  end;
end;
{=====}

procedure TVpCustomCalendar.SetWeekStarts(Value: TVpDayType);
begin
  if Value <> FWeekStarts then begin
    FWeekStarts := Value;
    if csLoading in ComponentState then
      Exit;
    calRebuildCalArray (FDate);
    Invalidate;
  end;
end;
{=====}

{$IFDEF DELPHI}
procedure TVpCustomCalendar.WMEraseBkgnd(var Msg: TWMEraseBkgnd);
begin
  Msg.Result := 1;   {don't erase background, just say we did. Shhhhhhh!}
end;
{=====}

procedure TVpCustomCalendar.WMGetDlgCode(var Msg: TWMGetDlgCode);
begin
  Msg.Result := DLGC_WANTARROWS;
end;
{=====}

procedure TVpCustomCalendar.WMKillFocus(var Msg: TWMKillFocus);
begin
  inherited;
  Invalidate;
end;
{=====}
{$ELSE}
procedure TVpCustomCalendar.WMEraseBkgnd(var Msg: TLMEraseBkgnd);
begin
  Msg.Result := 1;   {don't erase background, just say we did. Shhhhhhh!}
end;
{=====}
                           {
procedure TVpCustomCalendar.WMGetDlgCode(var Msg: TLMGetDlgCode);
begin
  Msg.Result := DLGC_WANTARROWS;
end;                        }
{=====}

procedure TVpCustomCalendar.WMKillFocus(var Msg: TLMKillFocus);
begin
  inherited;
  Invalidate;
end;
{=====}
{$ENDIF}

procedure TVpCustomCalendar.InitializeDefaultPopup;
var
  NewItem: TMenuItem;
begin
  if RSToday <> '' then begin
    NewItem := TMenuItem.Create (Self);
    NewItem.Caption := RSToday;
    NewItem.OnClick := PopupToday;
    FDefaultPopup.Items.Add (NewItem);
  end;

  if RSNextMonth <> '' then begin
    NewItem := TMenuItem.Create (Self);
    NewItem.Caption := RSNextMonth;
    NewItem.OnClick := PopupNextMonth;
    FDefaultPopup.Items.Add (NewItem);
  end;

  if RSPrevMonth <> '' then begin
    NewItem := TMenuItem.Create (Self);
    NewItem.Caption := RSPrevMonth;
    NewItem.OnClick := PopupPrevMonth;
    FDefaultPopup.Items.Add (NewItem);
  end;

  if RSNextYear <> '' then begin
    NewItem := TMenuItem.Create (Self);
    NewItem.Caption := RSNextYear;
    NewItem.OnClick := PopupNextYear;
    FDefaultPopup.Items.Add (NewItem);
  end;

  if RSPrevYear <> '' then begin
    NewItem := TMenuItem.Create (Self);
    NewItem.Caption := RSPrevYear;
    NewItem.OnClick := PopupPrevYear;
    FDefaultPopup.Items.Add (NewItem);
  end;
end;
{=====}

procedure TVpCustomCalendar.PopupToday(Sender: TObject);
begin
  SetDate (Now);
end;
{=====}

procedure TVpCustomCalendar.PopupNextMonth(Sender: TObject);
begin
  IncMonth (1);
end;
{=====}

procedure TVpCustomCalendar.PopupPrevMonth(Sender: TObject);
begin
  IncMonth (-1);
end;
{=====}

procedure TVpCustomCalendar.PopupNextYear(Sender: TObject);
begin
  IncYear (1);
end;
{=====}

procedure TVpCustomCalendar.PopupPrevYear(Sender: TObject);
begin
  IncYear (-1);
end;
{=====}

end.