home *** CD-ROM | disk | FTP | other *** search
/ Chip 2002 March / Chip_2002-03_cd1.bin / zkuste / delphi / kompon / d12456 / YEARPLAN.ZIP / YearPlan / yearplan.pas < prev   
Pascal/Delphi Source File  |  2001-12-15  |  70KB  |  2,221 lines
  1. unit Yearplan;
  2.  
  3. {  Year Planner component written by Jonathan Hosking, December 2001.
  4.  
  5.    Get future component updates from the following address
  6.    Website: http://www.the-hoskings.freeserve.co.uk/
  7.  
  8.    Send any bugs, suggestions, etc to the following Email
  9.    Email: jonathan@the-hoskings.freeserve.co.uk
  10.  
  11.    Thanks to Simon Nicholson for helping with the control updating routines
  12.    Email: Simon.Nicholson@helmstone.co.uk
  13.  
  14.    Thanks to Richard Haven for helping with the heading setup routine
  15.    Email: lanframe-news@scruznet.com
  16.  
  17.    Thanks to Wolfgang Kleinrath for helping with the data setup routine and
  18.    providing the code for the original routines for loading and saving cell
  19.    data to INI files
  20.    Email: wkleinrath@xpoint.at
  21.  
  22.    Thanks to Nacho Urenda for helping with the size calculation routine
  23.    Email: NachoUrenda@compuserve.com
  24.  
  25.    Thanks to Rob Schoenaker for improving the drawing routines
  26.    Email: rschoenaker@kraan.com
  27.  
  28.    Thanks to Robert Gesswein for adding the NoDayPriority and StartDayOfWeek
  29.    properties and for helping with the SetColorAtDate routine
  30.    Email: rgesswein@matmus.com
  31.  
  32.    Thanks to Paul Fisher for adding printing support, the original routines
  33.    for loading and saving cell data to streams, and for helping out with the
  34.    new cell selection routines
  35.    Email: PFisher@emis-support.demon.co.uk
  36.  
  37.    Thanks to Paolo Prandini for removing the range check errors in the
  38.    component routines.
  39.    Email: prandini@spe.it
  40.  
  41.    Thanks to Max Evans for the navigation buttons and graphical customisation
  42.    improvements.
  43.    Email: maxevans@australianfresh.com.au
  44.  
  45.    Thanks to Goldschmidt Jean-Jacques for the selection information routines
  46.    Email: jjgoldschmidt@freesurf.ch
  47.  
  48.    Thanks to Roberto Chieregato for the cell images routines
  49.    Email: robbz@freemail.it
  50.  
  51.    Thanks to Martin Roberts for fixing a bug with cell selections
  52.    Email: alias@mroberts1.force9.co.uk
  53.  
  54.    Thanks to Kaj Ekman for the code to draw images without stretching
  55.    Email: Kaj.Ekman@dlsoftware.fi
  56.  
  57.    Thanks to David Oakes for the code to control the display of default hints
  58.    Email: compdept@tbramsden.co.uk
  59.  
  60.    Thanks to Istvan Mesaros for the code for the OnSelectionEnd event
  61.    Email: istvan_70@yahoo.com
  62.  
  63.    Thanks to Christian Hackbart for fixing a bug in the cell selection
  64.    routines
  65.    Email: chackbart@web.de
  66.  
  67.    Thanks to Trev for the the code to clear the contents of all the cells and
  68.    the new year change events.
  69.    Email: Trev@visionhall.co.uk
  70.  
  71.    Thanks to Paul Bailey for helping out with the new printing routines.
  72.    Email: paul@cirrlus.co.za
  73.    
  74.    Thanks to Wolf Garber for fixing a bug in the cell selection routines and
  75.    the printing enhancements.
  76.    Email: wolf.garber@freenet.de
  77.  
  78.    Thanks to Jeugen Jakob for fixing a bug in the file loading and saving
  79.    routines.
  80.    Email: j.jakob@jakobsoftware.de
  81.  
  82.    Notes: CellData is not saved, even though it is a property.  This is
  83.           because it is changed at runtime
  84.  
  85.           Borland's routine for testing for leap years has been used here as
  86.           Delphi 1 had no such routine }
  87.  
  88. interface
  89.  
  90. { If you want to use a blob stream to load and save data, uncomment the next
  91.   line }
  92. {.$DEFINE USEBLOB}
  93.  
  94. uses
  95.   {$IFDEF WIN32} Windows, {$ELSE} WinTypes, WinProcs, {$ENDIF}
  96.   SysUtils, Messages, Classes, Graphics, Controls, Forms, Dialogs, stdctrls,
  97.   ExtCtrls, Menus, {$IFDEF USEBLOB} DBTables, {$ENDIF} Printers;
  98.  
  99. type
  100.   { Header and footer class }
  101.   TPrintTitle = class(TPersistent)
  102.   private
  103.     fAlignment: TAlignment;
  104.     fCaption: string;
  105.     fFont: TFont;
  106.     fOnChange: TNotifyEvent;
  107.     procedure SetAlignment(Val: TAlignment);
  108.     procedure SetCaption(Val: String);
  109.     procedure SetFont(Val: TFont);
  110.   public
  111.     constructor Create(UpdateEvent: TNotifyEvent);
  112.     destructor Destroy; override;
  113.     procedure UpdateControl;
  114.   published
  115.     property Alignment: TAlignment read fAlignment write SetAlignment default taLeftJustify;
  116.     property Caption: string read fCaption write SetCaption;
  117.     property Font: TFont read fFont write SetFont;
  118.     property OnChange: TNotifyEvent read fOnChange write fOnChange;
  119.   end;
  120.  
  121.   { Printer options class }
  122.   TPrintOptions = class(TPersistent)
  123.   private
  124.     fPrinterOrientation: TPrinterOrientation;
  125.     fPrintReductionSize: Integer;
  126.     fPrinterLeftMargin, fPrinterRightMargin: Integer;
  127.     fPrinterBottomMargin, fPrinterTopMargin: Integer;
  128.     fPrintHeader: TPrintTitle;
  129.     fPrintFooter: TPrintTitle;
  130.     fPreserveAspect: Boolean;
  131.   public
  132.     constructor Create(UpdateEvent: TNotifyEvent);
  133.     destructor Destroy; override;
  134.   published
  135.     property LeftMargin: Integer read fPrinterLeftMargin write fPrinterLeftMargin default 0;
  136.     property TopMargin: Integer read fPrinterTopMargin write fPrinterTopMargin default 0;
  137.     property RightMargin: Integer read fPrinterRightMargin write fPrinterRightMargin default 0;
  138.     property BottomMargin: Integer read fPrinterBottomMargin write fPrinterBottomMargin default 0;
  139.     property Orientation: TPrinterOrientation read fPrinterOrientation write fPrinterOrientation default poLandscape;
  140.     property ReductionSize: integer read fPrintReductionSize write fPrintReductionSize default 100;
  141.     property PrintHeader: TPrintTitle read fPrintHeader write fPrintHeader;
  142.     property PrintFooter: TPrintTitle read fPrintFooter write fPrintFooter;
  143.     property PreserveAspect: Boolean read fPreserveAspect write fPreserveAspect default True;
  144.   end;
  145.  
  146.   { YearPlannner component class }
  147.   TypDOW = (ypMonday,ypTuesday,ypWednesday,ypThursday,ypFriday,ypSaturday,ypSunday);
  148.   TypSel = (ypNotSelecting,ypSelecting,ypSelected);
  149.   TypSelSty = (ypNormal,ypRectangle);
  150.   TYearEvent = procedure(StDays,EnDays,StMonth,EnMonth:integer; StartDate,EndDate: TDateTime) of object;
  151.   { Compiling under Delphi 1 limits us to a 64KB data limit, so the record
  152.     cannot be too long.  Under later versions there are bigger data limits }
  153.   TCellData = record
  154.     CellHint: String{$IFNDEF WIN32}[125]{$ENDIF};
  155.     CellColor: TColor;
  156.     CellFont: TFont;
  157.     CustomColor: Boolean;
  158.     CustomFont: Boolean;
  159.     CellDate: TDateTime;
  160.     Selected: Boolean;
  161.     {$IFDEF WIN32}
  162.     CellImage: Integer;
  163.     {$ENDIF}
  164.     Tag: Longint;
  165.   end;
  166.   TCurrentDate = record
  167.     Day,Month: Byte;
  168.   end;
  169.   TYearPlanAbout = (abNone,abAbout);
  170.   TYearPlanner = class(TCustomControl)
  171.   private
  172.     { Private declarations }
  173.     Cells: Array[0..37,0..12] of string[9];
  174.     Heights: Array[0..12] of Integer;
  175.     Widths: Array[0..37] of Integer;
  176.     cX,cY,OldX,OldY: Integer;
  177.     InDay,InMonth: Integer;
  178.     FirstTickCount: {$IFDEF WIN32}Cardinal{$ELSE}LongInt{$ENDIF};
  179.     hPrinting,hUpdating,hWaiting,hWaitingToDestroy: Boolean;
  180.     hSelecting: TypSel;
  181.     HintDate: TDateTime;
  182.     HintWin: THintWindow;
  183.     PrinterPageHeight, PrinterPageWidth: Integer;
  184.     PrinterLeftMargin, PrinterTopMargin: Integer;
  185.     PrinterRightMargin, PrinterBottomMargin: Integer;
  186.     fStartDate: TDateTime;
  187.     fEndDate: TDateTime;
  188.     fAbout: TYearPlanAbout;
  189.     fAllowSelections: Boolean;
  190.     fControl: TBitmap;
  191.     fDayColor: TColor;
  192.     fDayFont: TFont;
  193.     {$IFDEF WIN32}
  194.     fEndEllipsis: Boolean;
  195.     {$ENDIF}
  196.     fFlatCells: Boolean;
  197.     fGridLines: Boolean;
  198.     fGridPen: TPen;
  199.     fHeadingColor: TColor;
  200.     fHintColor: TColor;
  201.     fHintFont: TFont;
  202.     fHintDelay: Integer;
  203.     {$IFDEF WIN32}
  204.     fImages: TImageList;
  205.     fMonthButtons: Boolean;
  206.     {$ENDIF}
  207.     fMonthColor: TColor;
  208.     fMonthFont: TFont;
  209.     fNoDayColor: TColor;
  210.     fNoDayPriority: Boolean;
  211.     fOnSelectionEnd: TNotifyEvent;
  212.     fOnYearChange: TNotifyEvent;
  213.     fOnYearChanged: TNotifyEvent;
  214.     fOnYearDblClick: TYearEvent;
  215.     fOnYearRightClick: TYearEvent;
  216.     fPrintOptions: TPrintOptions;
  217.     fSelectionColor: TColor;
  218.     fSelectionFont: TFont;
  219.     fSelectionStyle: TypSelSty;
  220.     {$IFDEF WIN32}
  221.     fSeperator: Boolean;
  222.     fSoftBorder: Boolean;
  223.     {$ENDIF}
  224.     fShowDefaultHint: Boolean;
  225.     fShowToday: Boolean;
  226.     fStartDayOfWeek: TypDOW;
  227.     fStretchImages: Boolean;
  228.     fStringList: TStringList;
  229.     fTodayCircleColour: TColor;
  230.     fTodayCircleFilled: Boolean;
  231.     fTodayTextColour: TColor;
  232.     fUseBitmap: Boolean;
  233.     fUseFreeSpace: Boolean;
  234.     fWeekendColor: TColor;
  235.     fWeekendHeadingColor: TColor;
  236.     fYear: Word;
  237.     fYearColor: TColor;
  238.     fYearFont: TFont;
  239.     fYearNavigators: Boolean;
  240.     fYearNavLeft: TRect;
  241.     fYearNavRight: TRect;
  242.     function FindFirstWeek(aYear: Word): TDateTime;
  243.     function IsLeapYear(Year: Word): Boolean;
  244.     procedure ProcessSelection;
  245.     procedure CalculateCalendar;
  246.     procedure CalculateData;
  247.     procedure CalculateNavigators;
  248.     procedure CalculateSizes;
  249.     procedure CircleToday(Canvas: TCanvas; CircleRect: TRect; const TodayText: String; InnerColor: TColor);
  250.     procedure OnGridPenChange(Sender:TObject);
  251.     procedure SetupHeadings;
  252.     procedure SetAllowSelections(Val: Boolean);
  253.     procedure SetDayColor(Val: TColor);
  254.     procedure SetDayFont(Val: TFont);
  255.     {$IFDEF WIN32}
  256.     procedure SetEndEllipsis(Val: Boolean);
  257.     {$ENDIF}
  258.     procedure SetFlatCells(Val: Boolean);
  259.     procedure SetGridLines(Val: Boolean);
  260.     procedure SetGridPen(Val: TPen);
  261.     procedure SetHeadingColor(Val: TColor);
  262.     procedure SetHintColor(Val: TColor);
  263.     procedure SetHintFont(Val: TFont);
  264.     procedure SetHintDelay(Val: Integer);
  265.     {$IFDEF WIN32}
  266.     procedure SetMonthButtons(Val: Boolean);
  267.     {$ENDIF}
  268.     procedure SetMonthColor(Val: TColor);
  269.     procedure SetMonthFont(Val: TFont);
  270.     procedure SetNoDayColor(Val: TColor);
  271.     procedure SetNoDayPriority(Val: Boolean);
  272.     procedure SetSelectionColor(Val: TColor);
  273.     procedure SetSelectionFont(Val: TFont);
  274.     procedure SetSelectionStyle(Val: TypSelSty);
  275.     {$IFDEF WIN32}
  276.     procedure SetSeperator(Val: Boolean);
  277.     procedure SetSoftBorder(Val: Boolean);
  278.     {$ENDIF}
  279.     procedure SetShowDefaultHint(Val: Boolean);
  280.     procedure SetShowToday(Val: Boolean);
  281.     procedure SetStartDayOfWeek(Val: TypDOW);
  282.     procedure SetStretchImages(Val: Boolean);
  283.     procedure SetTodayCircleColour(Val: TColor);
  284.     procedure SetTodayCircleFilled(Val: Boolean);
  285.     procedure SetTodayTextColour(Val: TColor);
  286.     procedure SetUseFreeSpace(Val: Boolean);
  287.     procedure SetWeekendColor(Val: TColor);
  288.     procedure SetWeekendHeadingColor(Val: TColor);
  289.     procedure SetYear(Val: Word);
  290.     procedure SetYearColor(Val: TColor);
  291.     procedure SetYearFont(Val:TFont);
  292.     procedure SetYearNavigators(Val: Boolean);
  293.     procedure ShowAbout(Val: TYearPlanAbout);
  294.     procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message wm_EraseBkgnd;
  295.     procedure WMLButtonDblClk(var Message: TWMLButtonDblClk); message wm_LButtonDblClk;
  296.     procedure WMLButtonDown(var Message: TWMLButtonDown); message wm_LButtonDown;
  297.     procedure WMLButtonUp(var Message: TWMLButtonUp); message wm_LButtonUp;
  298.     procedure WMRButtonDown(var Message: TWMRButtonDown); message wm_RButtonDown;
  299.     procedure WMMouseMove(var Message: TWMMouseMove); message wm_MouseMove;
  300.     procedure WMSize(var Message:TWMSize); message wm_Size;
  301.   protected
  302.     { Protected declarations }
  303.     procedure Paint; override;
  304.   public
  305.     { Public declarations }
  306.     CellData: Array[1..12,1..31] of TCellData;
  307.     CurrentDate: TCurrentDate;
  308.     EnDay: Integer;
  309.     EnMonth: Integer;
  310.     StDay: Integer;
  311.     StMonth: Integer;
  312.     StartDate: TDateTime;
  313.     EndDate: TDateTime;
  314.     procedure XYToCell(X,Y: Integer;var CellX,CellY: Integer);
  315.     constructor Create(AOwner: TComponent); override;
  316.     destructor Destroy; override;
  317.     procedure LoadFromFile(var fFile: File);
  318.     procedure LoadFromStream(var fStream:{$IFDEF USEBLOB}TBlobStream{$ELSE}TStream{$ENDIF});
  319.     procedure SaveToFile(var fFile: File);
  320.     procedure SaveToStream(var fStream:{$IFDEF USEBLOB}TBlobStream{$ELSE}TStream{$ENDIF});
  321.     procedure SetColorAtDate(dt: TDateTime; cellColor: TColor; UpdateControl: Boolean);
  322.     procedure SetFontAtDate(dt: TDateTime; cellFont: TFont; UpdateControl: Boolean);
  323.     procedure SetHintAtDate(dt: TDateTime; cellHint: String; UpdateControl: Boolean);
  324.     {$IFDEF WIN32}
  325.     procedure SetImageAtDate(dt: TDateTime; cellImage: Integer; UpdateControl: Boolean);
  326.     {$ENDIF}
  327.     function GetCellData(dt: TDateTime): TCellData;
  328.     procedure Print;
  329.     function GetStartDate: TDateTime;
  330.     function GetEndDate: TDateTime;
  331.     function IsSelected(date: TDateTime): Boolean;
  332.     procedure ClearSelection;
  333.     procedure SelectCells(sDate, eDate: TDateTime);
  334.     procedure SelectWeek(aWeek: Integer);
  335.     procedure ClearCells;
  336.     function WeekNumber(aDate: TDateTime): Integer;
  337.   published
  338.     { Published declarations }
  339.     property About: TYearPlanAbout read fAbout write ShowAbout default abNone;
  340.     property Align;
  341.     property AllowSelections: Boolean read fAllowSelections write SetAllowSelections default True;
  342.     property Color;
  343.     property DayColor: TColor read fDayColor write SetDayColor default clWhite;
  344.     property DayFont:TFont read fDayFont write SetDayFont;
  345.     property DragCursor;
  346.     property DragMode;
  347.     property DrawOffScreen: Boolean read fUseBitmap write fUseBitmap default True;
  348.     property Enabled;
  349.     {$IFDEF WIN32}
  350.     property EndEllipsis: Boolean read fEndEllipsis write SetEndEllipsis default False;
  351.     {$ENDIF}
  352.     property FlatCells: Boolean read fFlatCells write SetFlatCells default True;
  353.     property Font;
  354.     property GridLines: Boolean read fGridLines write SetGridLines default True;
  355.     property GridPen:TPen read fGridPen write SetGridPen;
  356.     property HeadingColor: TColor read fHeadingColor write SetHeadingColor default clGray;
  357.     property HintColor: TColor read fHintColor write SetHintColor default clYellow;
  358.     property HintFont: TFont read fHintFont write SetHintFont;
  359.     property HintDelay: Integer read fHintDelay write SetHintDelay default 0;
  360.     {$IFDEF WIN32}
  361.     property Images: TImageList read fImages write fImages;
  362.     property MonthButtons: Boolean read fMonthButtons write SetMonthButtons default False;
  363.     {$ENDIF}
  364.     property MonthColor: TColor read fMonthColor write SetMonthColor default clGray;
  365.     property MonthFont:TFont read fMonthFont write SetMonthFont;
  366.     property NoDayColor: TColor read fNoDayColor write SetNoDayColor default clSilver;
  367.     property NoDayPriority: Boolean read fNoDayPriority write SetNoDayPriority default False;
  368.     property ParentFont;
  369.     property ParentShowHint;
  370.     property PopupMenu;
  371.     property PrintOptions : TPrintOptions read fPrintOptions write fPrintOptions;
  372.     property SelectionColor: TColor read fSelectionColor write SetSelectionColor default clBlue;
  373.     property SelectionFont: TFont read fSelectionFont write SetSelectionFont;
  374.     property SelectionStyle: TypSelSty read fSelectionStyle write SetSelectionStyle default ypNormal;
  375.     {$IFDEF WIN32}
  376.     property Seperator: Boolean read fSeperator write SetSeperator default True;
  377.     property SoftBorder: Boolean read fSoftBorder write SetSoftBorder default False;
  378.     {$ENDIF}
  379.     property ShowDefaultHint: Boolean read fShowDefaultHint write SetShowDefaultHint default True;
  380.     property ShowHint;
  381.     property ShowToday: Boolean read fShowToday write SetShowToday;
  382.     property StartDayOfWeek: TypDOW read fStartDayOfWeek write SetStartDayOfWeek default ypMonday;
  383.     property StretchImages: Boolean read fStretchImages write SetStretchImages default False;
  384.     property TodayCircleColour: TColor read fTodayCircleColour write SetTodayCircleColour;
  385.     property TodayCircleFilled: Boolean read fTodayCircleFilled write SetTodayCircleFilled default False;
  386.     property TodayTextColour: TColor read fTodayTextColour write SetTodayTextColour;
  387.     property UseFreeSpace: Boolean read fUseFreeSpace write SetUseFreeSpace default True;
  388.     property Visible;
  389.     property WeekendColor: TColor read fWeekendColor write SetWeekendColor default clGray;
  390.     property WeekendHeadingColor: TColor read fWeekendHeadingColor write SetWeekendHeadingColor default clSilver;
  391.     property Year: Word read fYear write SetYear;
  392.     property YearColor: TColor read fYearColor write SetYearColor default clGray;
  393.     property YearFont:TFont read fYearFont write SetYearFont;
  394.     property YearNavigators: Boolean read fYearNavigators write SetYearNavigators default True;
  395.     property OnClick;
  396.     property OnDblClick: TYearEvent read fOnYearDblClick write fOnYearDblClick;
  397.     property OnDragDrop;
  398.     property OnDragOver;
  399.     property OnEndDrag;
  400.     property OnMouseDown;
  401.     property OnMouseMove;
  402.     property OnMouseUp;
  403.     property OnMouseRightClick: TYearEvent read fOnYearRightClick write fOnYearRightClick;
  404.     property OnSelectionEnd: TNotifyEvent read fOnSelectionEnd write fOnSelectionEnd;
  405.     property OnYearChange: TNotifyEvent read fOnYearChange write fOnYearChange;
  406.     property OnYearChanged: TNotifyEvent read fOnYearChanged write fOnYearChanged;
  407.   end;
  408.  
  409. procedure Register;
  410.  
  411. implementation
  412.  
  413. { TYearPlanner }
  414.  
  415. const
  416.   CopyRightStr: PChar = 'TYearPlanner Component v2.7 (15/12/2001)'+#13+#13+
  417.     'By Jonathan Hosking'+#13+#13+'Compiled in '+
  418.     {$IFDEF VER80}  'Delphi 1.0' {$ENDIF}
  419.     {$IFDEF VER90}  'Delphi 2.0' {$ENDIF}
  420.     {$IFDEF VER100} 'Delphi 3.0' {$ENDIF}
  421.     {$IFDEF VER120} 'Delphi 4.0' {$ENDIF}
  422.     {$IFDEF VER130} 'Delphi 5.0' {$ENDIF}
  423.     {$IFDEF VER140} 'Delphi 6.0' {$ENDIF}
  424.     {$IFDEF VER93}  'C++Builder 1.0' {$ENDIF}
  425.     {$IFDEF VER110} 'C++Builder 3.0' {$ENDIF}
  426.     {$IFDEF VER125} 'C++Builder 4.0' {$ENDIF};
  427.   MonthDays: array[1..12] of Integer = (31,28,31,30,31,30,31,31,30,31,30,31);
  428. var
  429.   CopyRightPtr: Pointer;
  430.  
  431. { Thanks to Paul Bailey for this procedure }
  432. constructor TPrintOptions.Create(UpdateEvent : TNotifyEvent);
  433. begin
  434.   inherited Create;
  435.   fPreserveAspect:= True;
  436.   fPrinterOrientation := poLandscape;
  437.   fPrintReductionSize :=  100;
  438.   fPrinterLeftMargin := 0;
  439.   fPrinterTopMargin := 0;
  440.   fPrinterRightMargin := 0;
  441.   fPrinterBottomMargin := 0;
  442.   fPrintHeader := TPrintTitle.Create(nil);
  443.   fPrintFooter := TPrintTitle.Create(nil);
  444. end;
  445.  
  446. { Thanks to Paul Bailey for this procedure }
  447. destructor TPrintOptions.Destroy;
  448. begin
  449.   fPrintFooter.Free;
  450.   fPrintHeader.Free;
  451.   inherited Destroy;
  452. end;
  453.  
  454. { Thanks to Paul Bailey for this procedure }
  455. procedure TPrintTitle.SetAlignment(Val: TAlignment);
  456. begin
  457.   if fAlignment <> Val then
  458.   begin
  459.     fAlignment := Val;
  460.     UpdateControl;
  461.   end;
  462. end;
  463.  
  464. { Thanks to Paul Bailey for this procedure }
  465. procedure TPrintTitle.SetCaption(Val: String);
  466. begin
  467.   if fCaption <> Val then
  468.   begin
  469.     fCaption := Val;
  470.     UpdateControl;
  471.   end;
  472. end;
  473.  
  474. { Thanks to Paul Bailey and Wolf Garber for this procedure }
  475. procedure TPrintTitle.SetFont(Val: TFont);
  476. begin
  477.   if fFont <> Val then
  478.   begin
  479.     fFont.Assign(Val);
  480.     UpdateControl;
  481.   end;
  482. end;
  483.  
  484. { Thanks to Paul Bailey for this procedure }
  485. constructor TPrintTitle.Create(UpdateEvent: TNotifyEvent);
  486. begin
  487.   inherited Create;
  488.   fFont := TFont.Create;
  489.   fCaption := '';
  490.   fAlignment := taLeftJustify;
  491. end;
  492.  
  493. { Thanks to Paul Bailey for this procedure }
  494. destructor TPrintTitle.Destroy;
  495. begin
  496.   fFont.Free;
  497.   inherited Destroy;
  498. end;
  499.  
  500. { Thanks to Paul Bailey for this procedure }
  501. procedure TPrintTitle.UpdateControl;
  502. begin
  503.   if Assigned(fOnChange) then fOnChange(Self);
  504. end;
  505.  
  506. { Gives you the date of the start of the first whole week in a specified
  507.   year.  The start day is determined by the StartDayOfWeek value }
  508. function TYearPlanner.FindFirstWeek(aYear: Word): TDateTime;
  509. var
  510.   sDay, tDay: Integer;
  511.   sDate: TDateTime;
  512.   dateOk: Boolean;
  513. begin
  514.   { We have to find the first whole week, but this depends on the day when
  515.     a week starts }
  516.   dateOk := False;
  517.   sDay := 1;
  518.   while not dateOk do
  519.   begin
  520.     { Find out what day of the week this date is }
  521.     sDate := EncodeDate(aYear, 1, sDay);
  522.     { Convert Delphi day of week to my day of week array }
  523.     tDay := (DayOfWeek(sDate) + 5) mod 7;
  524.     { Is this the start day ? }
  525.     if tDay = ord(fStartDayOfWeek) then dateOk := True;
  526.     { Try the next day }
  527.     inc(sDay);
  528.   end;
  529.   Result := sDate;
  530. end;
  531.  
  532. { Procedure to test for a leap year - This is the routine used in Delphi 5,
  533.   but I have used it here as Delphi 1 did not have such a procedure }
  534. function TYearPlanner.IsLeapYear(Year: Word): Boolean;
  535. begin
  536.   Result := (Year mod 4 = 0) and ((Year mod 100 <> 0) or (Year mod 400 = 0));
  537. end;
  538.  
  539. { Converts mouse coordinates to cell coordinates }
  540. procedure TYearPlanner.XYToCell(X,Y: Integer;var CellX,CellY: Integer);
  541. begin
  542.   { Work out the column }
  543.   if X < Widths[0] then CellX := 0 else
  544.   begin
  545.     CellX := ((X - Widths[0]) div Widths[1]) + 1;
  546.     if CellX > 37 then CellX := 37;
  547.   end;
  548.   { Work out the row }
  549.   if Y < Heights[0] then CellY := 0 else
  550.   begin
  551.     CellY := ((Y - Heights[0]) div Heights[1]) + 1;
  552.     if CellY > 12 then CellY := 12;
  553.   end;
  554. end;
  555.  
  556. { Processes a selection area }
  557. procedure TYearPlanner.ProcessSelection;
  558. var
  559.   sD, eD, sM, eM: Integer;
  560. begin
  561.   { Get the start date from the selected area }
  562.   sD := StDay;
  563.   sM := StMonth;
  564.   eD := EnDay;
  565.   eM := EnMonth;
  566.   if StDay = 0 then Inc(sD);
  567.   if StMonth = 0 then Inc(sM);
  568.   if (StDay > 7) then
  569.     while Cells[sD,sM] = '' do Dec(sD)
  570.   else
  571.     while Cells[sD,sM] = '' do Inc(sD);
  572.   fStartDate := EncodeDate(fYear, sM, StrToInt(Cells[sD,sM]));
  573.   { Get the end date from the selected area }
  574.   if EnDay = 0 then Inc(eD);
  575.   if EnMonth = 0 then Inc(eM);
  576.   if (EnDay > 7) then
  577.     while Cells[eD,eM] = '' do Dec(eD)
  578.   else
  579.     while Cells[eD,eM] = '' do Inc(eD);
  580.   fEndDate := EncodeDate(fYear, eM, StrToInt(Cells[eD,eM]));
  581. end;
  582.  
  583. { Reads in the cell data from an open file - Thanks to Jeurgen Jakob and
  584.   Roberto Chieregato for improving this procedure }
  585. procedure TYearPlanner.LoadFromFile(var fFile: File);
  586. var
  587.   fLength, numRead, X, Y: Integer;
  588. begin
  589.   { Read the calender data }
  590.   for X := 1 to 12 do
  591.     for Y := 1 to 31 do
  592.       with CellData[X, Y] do
  593.       begin
  594.         { Read in the cell data }
  595.         BlockRead(fFile, fLength, SizeOf(fLength), numRead);
  596.         if fLength > 0 then
  597.         begin
  598.           {$IFDEF WIN32}
  599.           SetLength(CellHint, fLength);
  600.           {$ENDIF}
  601.           BlockRead(fFile, CellHint[1], fLength, numRead);
  602.         end;
  603.         BlockRead(fFile, CellColor, SizeOf(CellColor), numRead);
  604.         BlockRead(fFile, CellFont, SizeOf(CellFont), numRead);
  605.         BlockRead(fFile, CustomColor, SizeOf(CustomColor), numRead);
  606.         BlockRead(fFile, CustomFont, SizeOf(CustomFont), numRead);
  607.         BlockRead(fFile, CellDate, SizeOf(CellDate), numRead);
  608.         BlockRead(fFile, Selected, SizeOf(Selected), numRead);
  609.         {$IFDEF WIN32}
  610.         BlockRead(fFile, CellImage, SizeOf(CellImage), numRead);
  611.         {$ENDIF}
  612.         BlockRead(fFile, Tag, SizeOf(Tag), numRead);
  613.       end;
  614. end;
  615.  
  616. { Reads in the cell data from an open stream - Thanks to Roberto Chieregato for
  617.   improving this procedure }
  618. procedure TYearPlanner.LoadFromStream(var fStream:{$IFDEF USEBLOB}TBlobStream{$ELSE}TStream{$ENDIF});
  619. var
  620.   fLength, X, Y: Integer;
  621. begin
  622.   { Read the calender data }
  623.   for X := 1 to 12 do
  624.     for Y := 1 to 31 do
  625.       with fStream, CellData[X, Y] do
  626.       begin
  627.         { Read in the cell data }
  628.         ReadBuffer(fLength, SizeOf(fLength));
  629.         if fLength > 0 then
  630.         begin
  631.           {$IFDEF WIN32}
  632.           SetLength(CellHint, fLength);
  633.           {$ENDIF}
  634.           ReadBuffer(CellHint[1], fLength);
  635.         end;
  636.         ReadBuffer(CellColor, SizeOf(CellColor));
  637.         ReadBuffer(CellFont, SizeOf(CellFont));
  638.         ReadBuffer(CustomColor, SizeOf(CustomColor));
  639.         ReadBuffer(CustomFont, SizeOf(CustomFont));
  640.         ReadBuffer(CellDate, SizeOf(CellDate));
  641.         ReadBuffer(Selected, SizeOf(Selected));
  642.         {$IFDEF WIN32}
  643.         ReadBuffer(CellImage, SizeOf(CellImage));
  644.         {$ENDIF}
  645.         ReadBuffer(Tag, SizeOf(Tag));
  646.       end;
  647. end;
  648.  
  649. { Saves the cell data to an open file - Thanks to Jeurgen Jakob and Roberto
  650.   Chieregato for improving this procedure }
  651. procedure TYearPlanner.SaveToFile(var fFile: File);
  652. var
  653.   fLength, numWritten, X, Y: Integer;
  654. begin
  655.   { Save the calender data }
  656.   for X := 1 to 12 do
  657.     for Y := 1 to 31 do
  658.       with CellData[X, Y] do
  659.       begin
  660.         { Save the cell data }
  661.         fLength := Length(CellHint);
  662.         BlockWrite(fFile, fLength, SizeOf(fLength), numWritten);
  663.         if fLength > 0 then
  664.           BlockWrite(fFile, CellHint[1], fLength, numWritten);
  665.         BlockWrite(fFile, CellColor, SizeOf(CellColor), numWritten);
  666.         BlockWrite(fFile, CellFont, SizeOf(CellFont), numWritten);
  667.         BlockWrite(fFile, CustomColor, SizeOf(CustomColor), numWritten);
  668.         BlockWrite(fFile, CustomFont, SizeOf(CustomFont), numWritten);
  669.         BlockWrite(fFile, CellDate, SizeOf(CellDate), numWritten);
  670.         BlockWrite(fFile, Selected, SizeOf(Selected), numWritten);
  671.         {$IFDEF WIN32}
  672.         BlockWrite(fFile, CellImage, SizeOf(CellImage));
  673.         {$ENDIF}
  674.         BlockWrite(fFile, Tag, SizeOf(Tag), numWritten);
  675.       end;
  676. end;
  677.  
  678. { Saves the cell data to an open stream - Thanks to Roberto Chieregato for
  679.   improving this procedure }
  680. procedure TYearPlanner.SaveToStream(var fStream:{$IFDEF USEBLOB}TBlobStream{$ELSE}TStream{$ENDIF});
  681. var
  682.   fLength, X, Y: Integer;
  683. begin
  684.   { Save the calender data }
  685.   for X := 1 to 12 do
  686.     for Y := 1 to 31 do
  687.       with fStream, CellData[X, Y] do
  688.       begin
  689.         { Save the cell data }
  690.         fLength := Length(CellHint);
  691.         WriteBuffer(fLength, SizeOf(fLength));
  692.         if fLength > 0 then
  693.           WriteBuffer(CellHint[1], fLength);
  694.         WriteBuffer(CellColor, SizeOf(CellColor));
  695.         WriteBuffer(CellFont, SizeOf(CellFont));
  696.         WriteBuffer(CustomColor, SizeOf(CustomColor));
  697.         WriteBuffer(CustomFont, SizeOf(CustomFont));
  698.         WriteBuffer(CellDate, SizeOf(CellDate));
  699.         WriteBuffer(Selected, SizeOf(Selected));
  700.         {$IFDEF WIN32}
  701.         WriteBuffer(CellImage, SizeOf(CellImage));
  702.         {$ENDIF}
  703.         WriteBuffer(Tag, SizeOf(Tag));
  704.       end;
  705. end;
  706.  
  707. { Thanks to Robert Gesswein for improving this procedure }
  708. procedure TYearPlanner.CalculateCalendar;
  709. var
  710.   I,J: Byte;
  711.   DaysInMonth,StartDay: Integer;
  712. begin
  713.   { Set the Year cell }
  714.   Cells[0, 0] := IntToStr(Self.Year);
  715.   { Clear the cell contents }
  716.   for I := 1 to 37 do
  717.     for J := 1 to 12 do
  718.       Cells[I,J] := '';
  719.   { Setup the cells }
  720.   for I := 1 to 12 do
  721.   begin
  722.     StartDay := DayOfWeek(EncodeDate(Year,I,1));
  723.     StartDay := (StartDay+7-Ord(fStartDayOfWeek)-2) mod 7;
  724.     DaysInMonth := MonthDays[I] + byte(IsLeapYear(Year) and (I = 2));
  725.     for J := 1 to DaysInMonth do Cells[J + StartDay,I] := IntToStr(J);
  726.   end;
  727. end;
  728.  
  729. { Thanks to Paul Fisher, Wolfgang Kleinrath and Roberto Chieregato for
  730.   improving this procedure }
  731. procedure TYearPlanner.CalculateData;
  732. var
  733.   I,J: Byte;
  734.   DaysInMonth: Integer;
  735. begin
  736.   { Setup the hints }
  737.   for I := 1 to 12 do
  738.   begin
  739.     DaysInMonth := MonthDays[I] + byte(IsLeapYear(Year) and (I = 2));
  740.     for J := 1 to DaysInMonth do
  741.     begin
  742.       with CellData[I,J] do
  743.       begin
  744.         CellColor := $00000000;
  745.         CellFont := fDayFont;
  746.         CustomColor := False;
  747.         CustomFont := False;
  748.         CellDate := EncodeDate(Year,I,J);
  749.         CellHint := '';
  750.         {$IFDEF WIN32}
  751.         CellImage := -1;
  752.         {$ENDIF}
  753.         Tag := -1;
  754.         Selected := False;
  755.       end;
  756.     end;
  757.   end;
  758. end;
  759.  
  760. { Thanks to Max Evans for this routine }
  761. procedure TYearPlanner.CalculateNavigators;
  762. var
  763.   sWidth,sHeight,y: Integer;
  764. begin
  765.   sWidth := GetSystemMetrics(SM_CXHSCROLL);
  766.   sHeight := GetSystemMetrics(SM_CYHSCROLL);
  767.   y := (Heights[0] - sHeight) div 2;
  768.   fYearNavLeft :=  Rect(0 + 1,y,1 + sWidth,y + sHeight);
  769.   fYearNavRight := Rect(Widths[0] - (sWidth + 1),y,Widths[0] - 1,y + sHeight);
  770. end;
  771.  
  772.  
  773. { Thanks to Max Evans, Nacho Urenda and Paul Fisher for helping with this
  774.   procedure }
  775. procedure TYearPlanner.CalculateSizes;
  776. var
  777.   I: Byte;
  778. begin
  779.   { Calculate the cell sizes based on whether or not we are printing or
  780.     using the free space }
  781.   if fUseFreeSpace then
  782.   begin
  783.     Heights[0] := Height - ((Height div 13) * 12);
  784.     Widths[0] := Width - ((Width div 41) * 37);
  785.   end
  786.   else
  787.   begin
  788.     Heights[0] := (Height div 13);
  789.     Widths[0] := (Width div 41) * 4;
  790.   end;
  791.   for I := 1 to 37 do Widths[I] := (Width div 41);
  792.   for I := 1 to 12 do Heights[I] := (Height div 13);
  793.   { Calculate the navigation button sizes }
  794.   CalculateNavigators;
  795. end;
  796.  
  797. { Thanks to Max Evans for this routine }
  798. procedure TYearPlanner.CircleToday(Canvas: TCanvas; CircleRect: TRect; const TodayText: String; InnerColor: TColor);
  799. begin
  800.   Canvas.Pen.Color := TodayCircleColour;
  801.   Canvas.Pen.Width := 2;
  802.   Canvas.Brush.Color := InnerColor;
  803.   with CircleRect do
  804.     Canvas.Ellipse(Left, Top, Right, Bottom);
  805.   Canvas.Font.Color := TodayTextColour;
  806.   {$IFDEF WIN32}
  807.   DrawText(Canvas.Handle, PChar(TodayText), -1, CircleRect, DT_VCENTER OR DT_CENTER OR DT_SINGLELINE);
  808.   {$ELSE}
  809.   DrawText(Canvas.Handle, @TodayText[1], -1, CircleRect, DT_VCENTER OR DT_CENTER OR DT_SINGLELINE);
  810.   {$ENDIF}
  811. end;
  812.  
  813. { Thanks to Max Evans for this routine }
  814. procedure TYearPlanner.OnGridPenChange(Sender:TObject);
  815. begin
  816.   Invalidate;
  817. end;
  818.  
  819. { Thanks to Paolo Prandini, Richard Haven and Robert Gesswein for this
  820.   improved procedure }
  821. procedure TYearPlanner.SetupHeadings;
  822. var
  823.    I,J: Byte;
  824. begin
  825.   for I := 1 to 37 do
  826.   begin
  827.     J := (((I - 1) + (Ord(fStartDayOfWeek))) mod 7) + 2;
  828.     if J = 8 then J := 1;
  829.     Cells[I,0] := ShortDayNames[J][1];
  830.   end;
  831.   for I := 1 to 12 do Cells[0,I] := LongMonthNames[I];
  832. end;
  833.  
  834. procedure TYearPlanner.SetAllowSelections(Val: Boolean);
  835. begin
  836.   if fAllowSelections <> Val then
  837.   begin
  838.     fAllowSelections := Val;
  839.     Invalidate;
  840.   end;
  841. end;
  842.  
  843. procedure TYearPlanner.SetDayColor(Val: TColor);
  844. begin
  845.   if fDayColor <> Val then
  846.   begin
  847.     fDayColor := Val;
  848.     Invalidate;
  849.   end;
  850. end;
  851.  
  852. { Thanks to Max Evans for this routine }
  853. procedure TYearPlanner.SetDayFont(Val: TFont);
  854. begin
  855.   if fDayFont <> Val then
  856.   begin
  857.     fDayFont.Assign(Val);
  858.     Invalidate;
  859.   end;
  860. end;
  861.  
  862. {$IFDEF WIN32}
  863. procedure TYearPlanner.SetEndEllipsis(Val: Boolean);
  864. begin
  865.   if fEndEllipsis <> Val then
  866.   begin
  867.     fEndEllipsis := Val;
  868.     Invalidate;
  869.   end;
  870. end;
  871. {$ENDIF}
  872.  
  873. procedure TYearPlanner.SetFlatCells(Val: Boolean);
  874. begin
  875.   if fFlatCells <> Val then
  876.   begin
  877.     fFlatCells := Val;
  878.     Invalidate;
  879.   end;
  880. end;
  881.  
  882. procedure TYearPlanner.SetGridLines(Val: Boolean);
  883. begin
  884.   if fGridLines <> Val then
  885.   begin
  886.     fGridLines := Val;
  887.     Invalidate;
  888.   end;
  889. end;
  890.  
  891. { Thanks to Max Evans for this routine }
  892. procedure TYearPlanner.SetGridPen(Val: TPen);
  893. begin
  894.   if fGridPen <> Val then
  895.   begin
  896.     fGridPen.Assign(Val);
  897.     Invalidate;
  898.   end;
  899. end;
  900.  
  901. procedure TYearPlanner.SetHeadingColor(Val: TColor);
  902. begin
  903.   if fHeadingColor <> Val then
  904.   begin
  905.     fHeadingColor := Val;
  906.     Invalidate;
  907.   end;
  908. end;
  909.  
  910. procedure TYearPlanner.SetHintColor(Val: TColor);
  911. begin
  912.   if fHintColor <> Val then
  913.   begin
  914.     fHintColor := Val;
  915.     Invalidate;
  916.   end;
  917. end;
  918.  
  919. procedure TYearPlanner.SetHintDelay(Val: Integer);
  920. begin
  921.   if fHintDelay <> Val then
  922.   begin
  923.     fHintDelay := Val;
  924.     if fHintDelay < 0 then fHintDelay := 0;
  925.     Invalidate;
  926.   end;
  927. end;
  928.  
  929. procedure TYearPlanner.SetHintFont(Val: TFont);
  930. begin
  931.   if fHintFont <> Val then
  932.   begin
  933.     fHintFont.Assign(Val);
  934.     Invalidate;
  935.   end;
  936. end;
  937.  
  938. { Thanks to Max Evans for this routine }
  939. {$IFDEF WIN32}
  940. procedure TYearPlanner.SetMonthButtons(Val: Boolean);
  941. begin
  942.   if fMonthButtons <> Val then
  943.   begin
  944.     fMonthButtons := Val;
  945.     Invalidate;
  946.   end;
  947. end;
  948. {$ENDIF}
  949.  
  950. procedure TYearPlanner.SetMonthColor(Val: TColor);
  951. begin
  952.   if fMonthColor <> Val then
  953.   begin
  954.     fMonthColor := Val;
  955.     Invalidate;
  956.   end;
  957. end;
  958.  
  959. { Thanks to Max Evans for this routine }
  960. procedure TYearPlanner.SetMonthFont(Val: TFont);
  961. begin
  962.   if fMonthFont <> Val then
  963.   begin
  964.     fMonthFont.Assign(Val);
  965.     Invalidate;
  966.   end;
  967. end;
  968.  
  969. procedure TYearPlanner.SetNoDayColor(Val: TColor);
  970. begin
  971.   if fNoDayColor <> Val then
  972.   begin
  973.     fNoDayColor := Val;
  974.     Invalidate;
  975.   end;
  976. end;
  977.  
  978. { Thanks to Robert Gesswein contributing this procedure }
  979. procedure TYearPlanner.SetNoDayPriority(Val: Boolean);
  980. begin
  981.   if fNoDayPriority <> Val then
  982.   begin
  983.     fNoDayPriority := Val;
  984.     Invalidate;
  985.   end;
  986. end;
  987.  
  988. procedure TYearPlanner.SetSelectionColor(Val: TColor);
  989. begin
  990.   if fSelectionColor <> Val then
  991.   begin
  992.     fSelectionColor := Val;
  993.     Invalidate;
  994.   end;
  995. end;
  996.  
  997. procedure TYearPlanner.SetSelectionFont(Val: TFont);
  998. begin
  999.   if fSelectionFont <> Val then
  1000.   begin
  1001.     fSelectionFont.Assign(Val);
  1002.     Invalidate;
  1003.   end;
  1004. end;
  1005.  
  1006. procedure TYearPlanner.SetSelectionStyle(Val: TypSelSty);
  1007. begin
  1008.   if fSelectionStyle <> Val then
  1009.   begin
  1010.     fSelectionStyle := Val;
  1011.     Invalidate;
  1012.   end;
  1013. end;
  1014.  
  1015. {$IFDEF WIN32}
  1016. procedure TYearPlanner.SetSeperator(Val: Boolean);
  1017. begin
  1018.   if fSeperator <> Val then
  1019.   begin
  1020.     fSeperator := Val;
  1021.     Invalidate;
  1022.   end;
  1023. end;
  1024.  
  1025. procedure TYearPlanner.SetSoftBorder(Val: Boolean);
  1026. begin
  1027.   if fSoftBorder <> Val then
  1028.   begin
  1029.     fSoftBorder := Val;
  1030.     Invalidate;
  1031.   end;
  1032. end;
  1033. {$ENDIF}
  1034.  
  1035. procedure TYearPlanner.SetShowDefaultHint(Val: Boolean);
  1036. begin
  1037.   if fShowDefaultHint <> Val then
  1038.   begin
  1039.     fShowDefaultHint := Val;
  1040.     Invalidate;
  1041.   end;
  1042. end;
  1043.  
  1044. { Thanks to Max Evans for this routine }
  1045. procedure TYearPlanner.SetShowToday(Val: Boolean);
  1046. begin
  1047.   if fShowToday <> Val then
  1048.   begin
  1049.     fShowToday := Val;
  1050.     Invalidate;
  1051.   end;
  1052. end;
  1053.  
  1054. { Thanks to Robert Gesswein for contributing this procedure }
  1055. procedure TYearPlanner.SetStartDayOfWeek(Val: TypDOW);
  1056. begin
  1057.   if fStartDayOfWeek <> Val then
  1058.   begin
  1059.     fStartDayOfWeek := Val;
  1060.     SetupHeadings;
  1061.     CalculateCalendar;
  1062.     CalculateData;
  1063.     Invalidate;
  1064.   end;
  1065. end;
  1066.  
  1067. procedure TYearPlanner.SetStretchImages(Val: Boolean);
  1068. begin
  1069.   if fStretchImages <> Val then
  1070.   begin
  1071.     fStretchImages := Val;
  1072.     Invalidate;
  1073.   end;
  1074. end;
  1075.  
  1076. { Thanks to Max Evans for this routine }
  1077. procedure TYearPlanner.SetTodayCircleColour(Val: TColor);
  1078. begin
  1079.   if fTodayCircleColour <> Val then
  1080.   begin
  1081.     fTodayCircleColour := Val;
  1082.     Invalidate;
  1083.   end;
  1084. end;
  1085.  
  1086. procedure TYearPlanner.SetTodayCircleFilled(Val: Boolean);
  1087. begin
  1088.   if fTodayCircleFilled <> Val then
  1089.   begin
  1090.     fTodayCircleFilled := Val;
  1091.     Invalidate;
  1092.   end;
  1093. end;
  1094.  
  1095. { Thanks to Max Evans for this routine }
  1096. procedure TYearPlanner.SetTodayTextColour(Val: TColor);
  1097. begin
  1098.   if fTodayTextColour <> Val then
  1099.   begin
  1100.     fTodayTextColour := Val;
  1101.     Invalidate;
  1102.   end;
  1103. end;
  1104.  
  1105. procedure TYearPlanner.SetUseFreeSpace(Val: Boolean);
  1106. begin
  1107.   if fUseFreeSpace <> Val then
  1108.   begin
  1109.     fUseFreeSpace := Val;
  1110.     CalculateSizes;
  1111.     Invalidate;
  1112.   end;
  1113. end;
  1114.  
  1115. procedure TYearPlanner.SetWeekendColor(Val: TColor);
  1116. begin
  1117.   if fWeekendColor <> Val then
  1118.   begin
  1119.     fWeekendColor := Val;
  1120.     Invalidate;
  1121.   end;
  1122. end;
  1123.  
  1124. procedure TYearPlanner.SetWeekendHeadingColor(Val: TColor);
  1125. begin
  1126.   if fWeekendHeadingColor <> Val then
  1127.   begin
  1128.     fWeekendHeadingColor := Val;
  1129.     Invalidate;
  1130.   end;
  1131. end;
  1132.  
  1133. procedure TYearPlanner.SetYear(Val: Word);
  1134. begin
  1135.   if fYear <> Val then
  1136.   begin
  1137.     { Handle the OnYearChange event, if there is one }
  1138.     if Assigned(fOnYearChange) then fOnYearChange(Self);
  1139.     { Change the year }
  1140.     fYear := Val;
  1141.     { Setup the calender }
  1142.     CalculateCalendar;
  1143.     CalculateData;
  1144.     { Clear the selection }
  1145.     ClearSelection;
  1146.     { Handle the OnYearChanged event, if there is one }
  1147.     if Assigned(fOnYearChanged) then fOnYearChanged(Self);
  1148.     { Update the control }
  1149.     Invalidate;
  1150.   end;
  1151. end;
  1152.  
  1153. { Thanks to Max Evans for this routine }
  1154. procedure TYearPlanner.SetYearColor(Val: TColor);
  1155. begin
  1156.   if fYearColor <> Val then
  1157.   begin
  1158.     fYearColor:= Val;
  1159.     Invalidate;
  1160.   end;
  1161. end;
  1162.  
  1163. { Thanks to Max Evans for this routine }
  1164. procedure TYearPlanner.SetYearFont(Val: TFont);
  1165. begin
  1166.   if fYearFont <> Val then
  1167.   begin
  1168.     fYearFont.Assign(Val);
  1169.     Invalidate;
  1170.   end;
  1171. end;
  1172.  
  1173. procedure TYearPlanner.SetYearNavigators(Val: Boolean);
  1174. begin
  1175.   if fYearNavigators <> Val then
  1176.   begin
  1177.     fYearNavigators := Val;
  1178.     Invalidate;
  1179.   end;
  1180. end;
  1181.  
  1182. procedure TYearPlanner.ShowAbout(Val: TYearPlanAbout);
  1183. begin
  1184.   if fAbout <> Val then
  1185.   begin
  1186.     if Val = abNone then fAbout := Val else
  1187.     begin
  1188.       fAbout := abNone;
  1189.       MessageDlg(StrPas(CopyRightStr), mtInformation, [mbOk], 0);
  1190.     end;
  1191.     Invalidate;
  1192.   end;
  1193. end;
  1194.  
  1195. procedure TYearPlanner.WMEraseBkgnd(var Message: TWMEraseBkgnd);
  1196. begin
  1197.   Message.Result := 1;
  1198. end;
  1199.  
  1200. { Thanks to Kaj Ekman, Max Evans, Paul Fisher, Rob Schoenaker and Roberto
  1201.   Chieregato for improving this routine }
  1202. procedure TYearPlanner.Paint;
  1203. var
  1204.   I,J: Byte;
  1205.   T,tH,tW,X,Y: Integer;
  1206.   fBorderRect, fCellRect, fSepRect, GridCellRect: TRect;
  1207.   fTodayDay, fTodayMonth, fTodayYear: Word;
  1208.   GridCol, OldColor: TColor;
  1209.   CurrWidth, CurrHeight : Integer;
  1210.   CellText: string;
  1211.   CellTextLen: Integer;
  1212.   TheCanvas: TCanvas;
  1213.   DrawDC: HDC;
  1214.   SizeRec: tSize;
  1215.   {$IFDEF WIN32}
  1216.   nXStart, nYStart, tXStart, tYStart: Integer;
  1217.   BitmapRect, TempDRect, TempSRect: TRect;
  1218.   ImageH, ImageIndex, ImageW: Integer;
  1219.   ImageBmp: TPicture;
  1220.   {$ELSE}
  1221.   bmpNavigator: TBitmap;
  1222.   {$ENDIF}
  1223.  
  1224. { This function determines if a cell is selected - Thanks to Roberto Chieregato
  1225.   for improving it }
  1226. function CellSelected: Boolean;
  1227. var
  1228.   crDate: TDateTime;
  1229. begin
  1230.   { By default we assume that the cell is not selected }
  1231.   Result := False;
  1232.   { We cannot select cells if selections are not allowed }
  1233.   if not fAllowSelections then Exit;
  1234.   { Is the cell selected ? }
  1235.   if SelectionStyle = ypNormal then
  1236.   begin
  1237.     { With normal selections we check the date range }
  1238.     crDate := EncodeDate(Year,J,StrToInt(Cells[I,J]));
  1239.     if (crDate >= fStartDate) and (crDate <= fEndDate) then Result := True;
  1240.   end
  1241.   else
  1242.     { With rectangular selections we check the selection coordinates }
  1243.     if (I >= StDay) and (I <= EnDay) and (J >= StMonth) and (J <= EnMonth)
  1244.       then Result := True;
  1245. end;
  1246.  
  1247. { This function determines the font to use for a day cell }
  1248. function CellFont: TFont;
  1249. var
  1250.   Dy,Mn: Byte;
  1251. begin
  1252.   Result := fDayFont;
  1253.   if Cells[I,J] = '' then Exit;
  1254.   { It's a calender day, so check for a custom font }
  1255.   Dy := StrToInt(Cells[I,J]);
  1256.   Mn := J;
  1257.   if CellData[Mn,Dy].CustomFont then
  1258.   begin
  1259.     Result := CellData[Mn,Dy].CellFont;
  1260.     Exit;
  1261.   end;
  1262.   { Check for a selection font }
  1263.   if CellSelected then Result := fSelectionFont;
  1264. end;
  1265.  
  1266. { This procedure works out the color of a cell - Thanks to Christian Hackbart,
  1267.   Max Evans, Paolo Prandini and Robert Gesswein for improving it }
  1268. function GridColor: TColor;
  1269. var
  1270.   Dy,Mn: Byte;
  1271. begin
  1272.   if I = 0 then
  1273.   begin
  1274.     if J = 0 then Result:= fYearColor else
  1275.       Result := fMonthColor;
  1276.     Exit;
  1277.   end;
  1278.   if (J > 0) and (J < 13) then
  1279.     if (Cells[I,J] <> '') then
  1280.     begin
  1281.       { It's a calender day, so check for a color }
  1282.       Dy := StrToInt(Cells[I,J]);
  1283.       Mn := J;
  1284.       CellData[Mn,Dy].Selected := CellSelected;
  1285.       if CellData[Mn,Dy].Selected then
  1286.       begin
  1287.         { It's a selected cell }
  1288.         Result := fSelectionColor;
  1289.         Exit;
  1290.       end;
  1291.       if CellData[Mn,Dy].CustomColor then
  1292.       begin
  1293.         { Use the custom color }
  1294.         Result := CellData[Mn,Dy].CellColor;
  1295.         CellData[Mn,Dy].Selected := False;
  1296.         Exit;
  1297.       end;
  1298.     end;
  1299.   if J = 13 then Result := fNoDayColor else
  1300.   begin
  1301.     if (((I+Ord(fStartDayOfWeek) in [0,6,7,13,14,20,21,27,28,34,35,41,42]) or (J = 0))
  1302.       and ((not fNoDayPriority) or (Cells[I,J] <> ''))) then
  1303.     begin
  1304.       { Weekend day or heading }
  1305.       Result := fWeekendColor;
  1306.       if J = 0 then
  1307.         if (I+Ord(fStartDayOfWeek) in [6,7,13,14,20,21,27,28,34,35,41,42]) then
  1308.           Result := fWeekendHeadingColor else
  1309.             Result := fHeadingColor;
  1310.     end
  1311.     else
  1312.     begin
  1313.       { Normal day }
  1314.       if Cells[I,J] = '' then Result := fNoDayColor
  1315.         else Result := fDayColor;
  1316.     end;
  1317.   end;
  1318. end;
  1319.  
  1320. { Thanks to Roberto Chieregato for this new routine }
  1321. {$IFDEF WIN32}
  1322. function GridImage: Integer;
  1323. var
  1324.   Dy,Mn: Byte;
  1325. begin
  1326.   Result := -1;
  1327.   if (Images <> nil) and (J > 0) and (J < 13) and (I > 0) then
  1328.     if (Cells[I,J] <> '') then
  1329.     begin
  1330.       Dy := StrToInt(Cells[I,J]);
  1331.       Mn := J;
  1332.       Result := CellData[Mn,Dy].CellImage;
  1333.     end;
  1334. end;
  1335. {$ENDIF}
  1336.  
  1337. { Thanks to Max Evans, Paolo Prandini and Rob Schoenaker for helping with
  1338.   this routine }
  1339. procedure DrawGridLines;
  1340. var
  1341.   L: Integer;
  1342.   LineHeight: Integer;
  1343. begin
  1344.   with TheCanvas do
  1345.   begin
  1346.     { Draw the grid }
  1347.     Pen.Assign(fGridPen);
  1348.     DrawDC := TheCanvas.Handle;
  1349.     X := Widths[0] - 1;
  1350.     Y := Heights[0] - 1;
  1351.     LineHeight := Heights[1] shl 2 + Heights[1] shl 3 + 1;
  1352.     for L := 1 to 38 do
  1353.     begin
  1354.       {$IFDEF WIN32}
  1355.       Windows.MoveToEx(DrawDC, X, Y, nil);
  1356.       Windows.LineTo(DrawDC, X, Y + LineHeight);
  1357.       {$ELSE}
  1358.       WinProcs.MoveToEx(DrawDC, X, Y, nil);
  1359.       WinProcs.LineTo(DrawDC, X, Y + LineHeight);
  1360.       {$ENDIF}
  1361.       if L < 38 then
  1362.         Inc(X, Widths[L]);
  1363.     end;
  1364.     for L := 1 to 13 do
  1365.     begin
  1366.       {$IFDEF WIN32}
  1367.       Windows.MoveToEx(DrawDC, Widths[0], Y, nil);
  1368.       Windows.LineTo(DrawDC, X, Y);
  1369.       {$ELSE}
  1370.       WinProcs.MoveToEx(DrawDC, Widths[0], Y, nil);
  1371.       WinProcs.LineTo(DrawDC, X, Y);
  1372.       {$ENDIF}
  1373.       if L < 13 then Inc(Y, Heights[L]);
  1374.     end;
  1375.   end;
  1376. end;
  1377.  
  1378. begin
  1379.   { Setup the offscreen bitmap }
  1380.   CalculateSizes;
  1381.   if (fUseBitmap) and not (csDesigning in ComponentState) then
  1382.   begin
  1383.     fControl.Width := Width;
  1384.     fControl.Height := Height;
  1385.     TheCanvas := fControl.Canvas;
  1386.   end
  1387.   else
  1388.     TheCanvas := Canvas;
  1389.   { Get today's date }
  1390.   DecodeDate(Date, fTodayYear, fTodayMonth, fTodayDay);
  1391.   with TheCanvas do
  1392.   begin
  1393.     { Draw the calender cells and text }
  1394.     Brush.Style := bsSolid;
  1395.     Font := Self.Font;
  1396.     DrawDC := TheCanvas.Handle;
  1397.     SetBKMode(DrawDC, TRANSPARENT);
  1398.     X := 0;
  1399.     for I := 0 to 37 do
  1400.     begin
  1401.       J := 0;
  1402.       Y := 0;
  1403.       CurrWidth := Widths[I];
  1404.       OldColor := GridColor;
  1405.       repeat
  1406.         T := Y;
  1407.         repeat
  1408.           Inc(Y,Heights[J]);
  1409.           Inc(J);
  1410.           GridCol := GridColor;
  1411.         until (GridCol <> OldColor) or (J = 13);
  1412.         GridCellRect := Rect(X, T, X + CurrWidth, Y);
  1413.         Brush.Color := OldColor;
  1414.         OldColor := GridCol;
  1415.         {$IFDEF WIN32}
  1416.         Windows.FillRect(DrawDC, GridCellRect, Brush.Handle);
  1417.         {$ELSE}
  1418.         WinProcs.FillRect(DrawDC, GridCellRect, Brush.Handle);
  1419.         {$ENDIF}
  1420.       until
  1421.         J = 13;
  1422.       Y := 0;
  1423.       for J := 0 to 12 do
  1424.       begin
  1425.         CurrHeight := Heights[J];
  1426.         GridCellRect := Rect(X,Y + 1,X + CurrWidth - 1,Y + CurrHeight - 1);
  1427.         if (I = 0) or (J = 0) then
  1428.         {$IFDEF WIN32}
  1429.         fSepRect:= GridCellRect;
  1430.         InFlateRect(fSepRect,-10,0);
  1431.         if fSeperator then DrawEdge(DrawDC, fSepRect, EDGE_RAISED, BF_BOTTOM);
  1432.         { Draw the month buttons and flat cells }
  1433.         if (fMonthButtons) and (I = 0) and (J > 0) then
  1434.           DrawEdge(DrawDC, GridCellRect, EDGE_RAISED, BF_RECT OR BF_SOFT)
  1435.         else
  1436.           if not fFlatCells then
  1437.             DrawEdge(DrawDC, GridCellRect, BDR_RAISEDINNER, BF_RECT);
  1438.         {$ELSE}
  1439.         if not fFlatCells then
  1440.           Frame3D(TheCanvas,GridCellRect,clBtnHighlight,clBtnShadow,1);
  1441.         {$ENDIF}
  1442.         {$IFDEF WIN32}
  1443.         { Draw the cell images }
  1444.         ImageIndex := GridImage;
  1445.         If ImageIndex > -1 then
  1446.         begin
  1447.           ImageBmp := TPicture.Create;
  1448.           { Do we want to draw a stretched image ? }
  1449.           if fStretchImages then
  1450.           begin
  1451.             { Stretch the image to fill the cell }
  1452.             BitmapRect := Rect(X, Y, X + CurrWidth, Y + CurrHeight);
  1453.             Images.GetBitmap(ImageIndex, ImageBmp.Bitmap);
  1454.             TheCanvas.StretchDraw(BitmapRect, ImageBmp.Bitmap);
  1455.           end
  1456.           else
  1457.           begin
  1458.             { Center the image in the cell }
  1459.             Images.GetBitmap(ImageIndex, ImageBmp.Bitmap);
  1460.             ImageW := ImageBmp.Bitmap.Width;
  1461.             ImageH := ImageBmp.Bitmap.Height;
  1462.             { Crop the image so that it is not drawn over other cells }
  1463.             if ImageBmp.Width > CurrWidth then
  1464.             begin
  1465.               { Crop the image width }
  1466.               tXStart := (ImageW - CurrWidth) div 2;
  1467.               TempSRect := Rect(tXStart, 0, tXStart + CurrWidth, ImageH);
  1468.               TempDRect := Rect(0, 0, CurrWidth, ImageH);
  1469.               with ImageBmp.Bitmap do Canvas.CopyRect(TempDRect,Canvas,TempSRect);
  1470.               ImageBmp.Bitmap.Width := CurrWidth;
  1471.               ImageW := ImageBmp.Bitmap.Width;
  1472.             end;
  1473.             if ImageBmp.Height > CurrHeight then
  1474.             begin
  1475.               { Crop the image height }
  1476.               tYStart := (ImageH - CurrHeight) div 2;
  1477.               TempSRect := Rect(0, tYStart, CurrWidth, tYStart + CurrHeight);
  1478.               TempDRect := Rect(0, 0, ImageW, CurrHeight);
  1479.               with ImageBmp.Bitmap do Canvas.CopyRect(TempDRect,Canvas,TempSRect);
  1480.               ImageBmp.Bitmap.Height := CurrHeight;
  1481.               ImageH := ImageBmp.Bitmap.Height;
  1482.             end;
  1483.             { Work out the top left coordinates of the image }
  1484.             nXStart := (X + (CurrWidth div 2)) - (ImageW div 2);
  1485.             nYStart := (Y + (CurrHeight div 2)) - (ImageH div 2);
  1486.             { Draw the image }
  1487.             TheCanvas.Draw(nXStart, nYStart, ImageBmp.Bitmap);
  1488.           end;
  1489.           ImageBmp.Free;
  1490.         end
  1491.         else
  1492.         begin
  1493.           {$ENDIF}
  1494.           CellText := Cells[I,J];
  1495.           CellTextLen := Length(CellText);
  1496.           { Select the font to use }
  1497.           if CellTextLen <> 0 then
  1498.           begin
  1499.             if I = 0 then
  1500.             begin
  1501.               { Month Cell }
  1502.               Font := fMonthFont;
  1503.               DrawDC := TheCanvas.Handle;
  1504.               SetBKMode(DrawDC, TRANSPARENT);
  1505.             end;
  1506.             if J = 0 then
  1507.             begin
  1508.               { Day Cell }
  1509.               Font := fDayFont;
  1510.               DrawDC := TheCanvas.Handle;
  1511.               SetBKMode(DrawDC, TRANSPARENT);
  1512.             end;
  1513.             if (J = 0) and (I = 0) then
  1514.             begin
  1515.               { Year Cell }
  1516.               Font := fYearFont;
  1517.               DrawDC := TheCanvas.Handle;
  1518.               SetBKMode(DrawDC, TRANSPARENT);
  1519.               if fYearNavigators then
  1520.               begin
  1521.                 { Draw the year navigation buttons }
  1522.                 CalculateNavigators;
  1523.                 {$IFDEF WIN32}
  1524.                 if fMonthButtons then
  1525.                 begin
  1526.                   DrawFrameControl(DrawDC, fYearNavLeft, DFC_SCROLL, DFCS_SCROLLLEFT);
  1527.                   DrawFrameControl(DrawDC, fYearNavRight, DFC_SCROLL, DFCS_SCROLLRIGHT);
  1528.                 end
  1529.                 else
  1530.                 begin
  1531.                   DrawFrameControl(DrawDC, fYearNavLeft, DFC_SCROLL, DFCS_SCROLLLEFT or DFCS_FLAT);
  1532.                   DrawFrameControl(DrawDC, fYearNavRight, DFC_SCROLL, DFCS_SCROLLRIGHT or DFCS_FLAT);
  1533.                 end;
  1534.                 {$ELSE}
  1535.                 bmpNavigator := TBitmap.Create;
  1536.                 try
  1537.                   bmpNavigator.Handle := LoadBitmap(0,pchar(obm_LfArrow));
  1538.                   BitBlt(DrawDC,fYearNavLeft.Left,fYearNavLeft.Top,fYearNavLeft.Right - fYearNavLeft.Left,
  1539.                     fYearNavLeft.Bottom - fYearNavLeft.Top, bmpNavigator.Canvas.Handle,0,0,SrcCopy);
  1540.                   bmpNavigator.ReleaseHandle;
  1541.                   bmpNavigator.Handle := LoadBitmap(0,pchar(obm_RGArrow));
  1542.                   BitBlt(DrawDC,fYearNavRight.Left,fYearNavRight.Top,fYearNavRight.Right - fYearNavRight.Left,
  1543.                     fYearNavRight.Bottom - fYearNavRight.Top, bmpNavigator.Canvas.Handle,0,0,SrcCopy)
  1544.                 finally
  1545.                   bmpNavigator.Free;
  1546.                 end;
  1547.                 {$ENDIF}
  1548.               end;
  1549.             end;
  1550.             if (J > 0) and (I > 0) then
  1551.             begin
  1552.               { Normal Cells }
  1553.               Font := CellFont;
  1554.               DrawDC := TheCanvas.Handle;
  1555.               SetBKMode(DrawDC, TRANSPARENT);
  1556.             end;
  1557.             { Draw the text in the center of the cell }
  1558.             {$IFNDEF WIN32}
  1559.             GetTextExtentPoint(DrawDC, @CellText[1], CellTextLen, SizeRec);
  1560.             {$ELSE}
  1561.             GetTextExtentPoint32(DrawDC, PChar(CellText), CellTextLen, SizeRec);
  1562.             {$ENDIF}
  1563.             tW := (CurrWidth - SizeRec.cx) shr 1;
  1564.             tH := (CurrHeight - SizeRec.cy) shr 1;
  1565.             {$IFDEF WIN32}
  1566.             if fEndEllipsis then
  1567.             begin
  1568.               fCellRect := Rect(X + tW,Y + tH, (X + tW) + CurrWidth,(Y + tH) + CurrHeight);
  1569.               DrawText(DrawDC,PChar(@CellText[1]),-1,fCellRect,DT_VCENTER OR DT_CENTER OR DT_END_ELLIPSIS);
  1570.             end
  1571.             else
  1572.               Windows.TextOut(DrawDC, X + tW, Y + tH, PChar(CellText), CellTextLen);
  1573.             {$ELSE}
  1574.               WinProcs.TextOut(DrawDC, X + tW, Y + tH, @CellText[1], CellTextLen);
  1575.             {$ENDIF}
  1576.             if (fShowToday) and (Cells[I, J] = IntToStr(fTodayDay)) and
  1577.               (J = fTodayMonth) and (fYear = fTodayYear) then
  1578.             begin
  1579.               if fTodayCircleFilled then
  1580.                 CircleToday(TheCanvas, GridCellRect, IntToStr(fTodayDay), fTodayCircleColour)
  1581.               else
  1582.                 CircleToday(TheCanvas, GridCellRect, IntToStr(fTodayDay), GridColor);
  1583.             end;
  1584.           end;
  1585.         {$IFDEF WIN32}
  1586.         end;
  1587.         {$ENDIF}
  1588.         Inc(Y,CurrHeight);
  1589.       end;
  1590.       Inc(X,CurrWidth);
  1591.     end;
  1592.     if fGridlines then DrawGridLines;
  1593.     {$IFDEF WIN32}
  1594.     if fSoftBorder then
  1595.     begin
  1596.       SetBKMode(DrawDC, OPAQUE);
  1597.       fBorderRect:= Rect(0,0,Width,Height);
  1598.       DrawEdge(DrawDC,fBorderRect,EDGE_ETCHED,BF_RECT);
  1599.     end;
  1600.     {$ENDIF}
  1601.   end;
  1602.   { Now copy the bitmap to the screen }
  1603.   if fUseBitmap then
  1604.     BitBlt(Canvas.Handle, 0, 0, Width, Height, DrawDC, 0, 0, SRCCOPY);
  1605.   { If we are printing, copy the canvas and stretch it to the page }
  1606.   if hPrinting then
  1607.     StretchBlt(Printer.Canvas.Handle, PrinterLeftMargin, PrinterTopMargin,
  1608.       PrinterPageWidth, PrinterPageHeight, Canvas.Handle, 0, 0,
  1609.       Width, Height, SRCCOPY);
  1610. end;
  1611.  
  1612. { Thanks to Max Evans for improving this routine }
  1613. constructor TYearPlanner.Create(AOwner: TComponent);
  1614. var
  1615.   Dy,Mn,Yr: Word;
  1616. begin
  1617.   { Setup the control }
  1618.   Inherited Create(AOwner);
  1619.   HintWin := THintWindow.Create(Self);
  1620.   fStringList := TStringList.Create;
  1621.   fPrintOptions := TPrintOptions.Create(nil);
  1622.   CopyRightPtr := @CopyRightStr;
  1623.   Width := 615;
  1624.   Height := 300;
  1625.   Color := clGray;
  1626.   DecodeDate(Date, Yr, Mn, Dy);
  1627.   fAbout := abNone;
  1628.   fAllowSelections := True;
  1629.   fDayColor := clWhite;
  1630.   {$IFDEF WIN32}
  1631.   fEndEllipsis := False;
  1632.   {$ENDIF}
  1633.   fFlatCells := True;
  1634.   fGridLines := True;
  1635.   fHeadingColor := clGray;
  1636.   fHintColor := clYellow;
  1637.   fHintDelay := 0;
  1638.   fMonthColor := clGray;
  1639.   {$IFDEF WIN32}
  1640.   fMonthButtons := False;
  1641.   {$ENDIF}
  1642.   fNoDayColor := clSilver;
  1643.   fNoDayPriority := False;
  1644.   fSelectionColor := clBlue;
  1645.   fSelectionStyle := ypNormal;
  1646.   {$IFDEF WIN32}
  1647.   fSeperator := True;
  1648.   fSoftBorder := False;
  1649.   {$ENDIF}
  1650.   fShowDefaultHint := True;
  1651.   fStartDayOfWeek := ypMonday;
  1652.   fStretchImages := False;
  1653.   fTodayCircleColour := clMaroon;
  1654.   fTodayCircleFilled := False;
  1655.   fTodayTextColour:= clWhite;
  1656.   fUseBitmap := True;
  1657.   fUseFreeSpace := True;
  1658.   fWeekendColor := clGray;
  1659.   fWeekendHeadingColor := clSilver;
  1660.   fYear := Yr;
  1661.   fYearColor:= clGray;
  1662.   {$IFDEF WIN32}
  1663.   fYearNavigators := True;
  1664.   {$ENDIF}
  1665.   fStartDate := Now;
  1666.   fEndDate := Now;
  1667.   hUpdating := False;
  1668.   hWaiting := False;
  1669.   hWaitingToDestroy := False;
  1670.   CurrentDate.Day := 0;
  1671.   CurrentDate.Month := 0;
  1672.   OldX := -1;
  1673.   OldY := -1;
  1674.   hPrinting := False;
  1675.   hSelecting := ypNotSelecting;
  1676.   { Create the off screen bitmap }
  1677.   fControl := TBitmap.Create;
  1678.   { Create the fonts }
  1679.   fDayFont := TFont.Create;
  1680.   fHintFont := TFont.Create;
  1681.   fMonthFont := TFont.Create;
  1682.   fSelectionFont := TFont.Create;
  1683.   fYearFont := TFont.Create;
  1684.   fGridPen := TPen.Create;
  1685.   fGridPen.OnChange:= OnGridPenChange;
  1686.   { Setup the calender }
  1687.   SetupHeadings;
  1688.   CalculateCalendar;
  1689.   CalculateData;
  1690.   CalculateSizes;
  1691. end;
  1692.  
  1693. { Thanks to Max Evans for improving this routine }
  1694. destructor TYearPlanner.Destroy;
  1695. begin
  1696.   { Kill the control }
  1697.   fPrintOptions.Free;
  1698.   fStringList.Free;
  1699.   { Inform the hint window that the control is destroying }
  1700.   hWaitingToDestroy := True;
  1701.   { If a hint is being displayed, we release the hint window }
  1702.   if hUpdating then HintWin.ReleaseHandle;
  1703.   { Free the hint window }
  1704.   HintWin.Free;
  1705.   { Free used bitmap }
  1706.   fControl.Free;
  1707.   { Free the fonts }
  1708.   fGridPen.OnChange:= nil;
  1709.   fGridPen.Free;
  1710.   fYearFont.Free;
  1711.   fSelectionFont.Free;
  1712.   fMonthFont.Free;
  1713.   fHintFont.Free;
  1714.   fDayFont.Free;
  1715.   { Here the control is destroyed.  If a hint was being displayed, the hint
  1716.     procedure will safely exit by picking up the csDestroying flag in the
  1717.     ComponentState property }
  1718.   Inherited Destroy;
  1719. end;
  1720.  
  1721. procedure TYearPlanner.WMLButtonDblClk(var Message: TWMLButtonDblClk);
  1722. begin
  1723.   { If a selection has been made, and a double click procedure has been set,
  1724.     execute it }
  1725.   if (hSelecting = ypSelected) and (Assigned(fOnYearDblClick)) then
  1726.     fOnYearDblClick(StDay,EnDay,EnMonth,StMonth,fStartDate,fEndDate);
  1727. end;
  1728.  
  1729. { Thanks to Martin Roberts, Max Evans, Paul Fisher and Wolf Garber for
  1730.   helping with this routine }
  1731. procedure TYearPlanner.WMLButtonDown(var Message: TWMLButtonDown);
  1732. var
  1733.   Pt,Temp: TPoint;
  1734.   tX,tY: Integer;
  1735.   fOnClick: TNotifyEvent;
  1736. begin
  1737.   Inherited;
  1738.   if fYearNavigators then
  1739.   begin
  1740.     { Check the navigation buttons }
  1741.     GetCursorPos(Pt);
  1742.     Pt := ScreenToClient(Pt);
  1743.     if PtInRect(fYearNavLeft,Pt) then
  1744.     begin
  1745.       { User clicked the previous year button }
  1746.       Year := Year - 1;
  1747.       Invalidate;
  1748.       Exit;
  1749.     end;
  1750.     if PtInRect(fYearNavRight,Pt) then
  1751.     begin
  1752.       { User clicked the next year button }
  1753.       Year := Year + 1;
  1754.       Invalidate;
  1755.       Exit;
  1756.     end;
  1757.   end;
  1758.   { Check to see if the mouse is over a cell }
  1759.   Temp := ClientToScreen(Point(Message.XPos,Message.YPos));
  1760.   if not (FindDragTarget(Temp, True) = Self) then Exit;
  1761.   XYToCell(Message.XPos,Message.YPos,tX,tY);
  1762.   { If we are selecting in date range style, we must select a cell with a date }
  1763.   if ((tx = 0) or (ty = 0) or (cells[tx,ty] = '')) and (fSelectionStyle = ypNormal) then
  1764.   begin
  1765.     ClearSelection;
  1766.     Exit;
  1767.   end;
  1768.   { If the user has assigned an OnClick event, we cannot use selections }
  1769.   fOnClick := OnClick;
  1770.   if not Assigned(fOnClick) then hSelecting := ypSelecting;
  1771.   { Set the initial and start coordinates }
  1772.   InDay := tX;
  1773.   InMonth := tY;
  1774.   StDay := InDay;
  1775.   StMonth := InMonth;
  1776.   EnDay := InDay;
  1777.   EnMonth := InMonth;
  1778.   { Set the date range, if we are using date range selection style }
  1779.   if fSelectionStyle = ypNormal then
  1780.   begin
  1781.     fStartDate := EncodeDate(fYear, ty, StrToInt(Cells[tx,ty]));
  1782.     fEndDate := fStartDate;
  1783.   end;
  1784.   { Update the control }
  1785.   Invalidate;
  1786. end;
  1787.  
  1788. { Thanks to Paul Fisher, Goldschmidt Jean-Jacques and Istvan Mesaros for
  1789.   helping with this routine }
  1790. procedure TYearPlanner.WMLButtonUp(var Message: TWMLButtonUp);
  1791. var
  1792.   CountX,CountY: Integer;
  1793. begin
  1794.   { We cannot allow the user to select a range of cells which do not
  1795.     contain dates }
  1796.   hSelecting := ypNotSelecting;
  1797.   for CountX := StDay to EnDay do
  1798.     for CountY := StMonth to EnMonth do
  1799.       if Cells[CountX,CountY] <> '' then
  1800.         hSelecting := ypSelected;
  1801.   { Process the selection coordinates }
  1802.   ProcessSelection;
  1803.   { Update the start and end date variables }
  1804.   StartDate := fStartDate;
  1805.   EndDate := fEndDate;
  1806.   { Handle an OnSelectionEnd event if one exists }
  1807.   if Assigned(fOnSelectionEnd) then fOnSelectionEnd(Self);
  1808.   Inherited;
  1809. end;
  1810.  
  1811. { Thanks to Paul Fisher for helping with this routine }
  1812. procedure TYearPlanner.WMRButtonDown(var Message: TWMRButtonDown);
  1813. begin
  1814.   Inherited;
  1815.   { If a selection has been made, and a right click procedure has been set,
  1816.     execute it }
  1817.   if (hSelecting = ypSelected) and (Assigned(fOnYearRightClick)) then
  1818.     fOnYearRightClick(StDay,EnDay,EnMonth,StMonth,fStartDate, fEndDate);
  1819. end;
  1820.  
  1821. procedure TYearPlanner.WMMouseMove(var Message: TWMMouseMove);
  1822. var
  1823.   Temp: TPoint;
  1824.   HintText, TmpHint, TmpText: String;
  1825.   HintRect: TRect;
  1826.   HDelay : {$IFDEF WIN32}Cardinal{$ELSE}LongInt{$ENDIF};
  1827.   HintH, HintLines, HintSH, HintW: Integer;
  1828.   Dy,Mn: Byte;
  1829.   swapTmp:integer;
  1830. begin
  1831.   { If the control is destroying we cannot continue }
  1832.   if hWaitingToDestroy then Exit;
  1833.   Inherited;
  1834.   { Check to see if the mouse is over a cell }
  1835.   Temp := ClientToScreen(Point(Message.XPos,Message.YPos));
  1836.   if not (FindDragTarget(Temp, True) = Self) then Exit;
  1837.   XYToCell(Message.XPos,Message.YPos,cX,cY);
  1838.   { We do not use hints when selecting cells }
  1839.   if hSelecting = ypSelecting then
  1840.   begin
  1841.     { Update the selection coordinates }
  1842.     StDay := InDay;
  1843.     StMonth := InMonth;
  1844.     EnDay := cX;
  1845.     EnMonth := cY;
  1846.     { Do we need to change the selection coordinates ? }
  1847.     if fSelectionStyle = ypNormal then
  1848.     begin
  1849.       if (StMonth > EnMonth) or ((StMonth = EnMonth) and (StDay > EnDay)) then
  1850.       begin
  1851.         { With normal selections we reverse the date range }
  1852.         swapTmp := StDay;
  1853.         StDay := EnDay;
  1854.         EnDay := swapTmp;
  1855.         swapTmp := StMonth;
  1856.         StMonth := EnMonth;
  1857.         EnMonth := swapTmp;
  1858.       end;
  1859.     end
  1860.     else
  1861.     begin
  1862.       { With rectangular selections, we simply switch the coordinates }
  1863.       if StDay > EnDay then
  1864.       begin
  1865.         swapTmp := StDay;
  1866.         StDay := EnDay;
  1867.         EnDay := swapTmp;
  1868.       end;
  1869.       if StMonth > EnMonth then
  1870.       begin
  1871.         swapTmp := StMonth;
  1872.         StMonth := EnMonth;
  1873.         EnMonth := swapTmp;
  1874.       end;
  1875.     end;
  1876.     { Process the selection coordinates }
  1877.     ProcessSelection;
  1878.     { Repaint the control }
  1879.     Invalidate;
  1880.     Exit;
  1881.   end;
  1882.   { Is this cell a calender day? }
  1883.   if ((OldX = cX) and (OldY = cY)) or (cX = 0) or (cY = 0) or
  1884.     (Cells[cX,cY] = '') then Exit;
  1885.   { Update the current date }
  1886.   CurrentDate.Day := StrToInt(Cells[cX,cY]);
  1887.   CurrentDate.Month := cY;
  1888.   { Now check to see if we can use hints }
  1889.   if not (Application.ShowHint and (ShowHint or ParentShowHint)) then Exit;
  1890.   { Do we show this hint? }
  1891.   if (CellData[cY,CurrentDate.Day].CellHint = '') and (not fShowDefaultHint) then Exit;
  1892.   { If a hint is being displayed, we mark a hint status flag to say that
  1893.     another hint is waiting }
  1894.   if hUpdating then
  1895.   begin
  1896.     hWaiting := True;
  1897.     Exit;
  1898.   end;
  1899.   { Now we setup the hint }
  1900.   OldX := cX;
  1901.   OldY := cY;
  1902.   Dy := CurrentDate.Day;
  1903.   Mn := CurrentDate.Month;
  1904.   HintText := CellData[Mn,Dy].CellHint;
  1905.   if HintText = '' then HintText := DateTimeToStr(EncodeDate(Year,Mn,Dy));
  1906.   HintDate := CellData[Mn,Dy].CellDate;
  1907.   { Set the hint status flags }
  1908.   hUpdating := True;
  1909.   hWaiting := False;
  1910.   { Set the hint width }
  1911.   TmpHint := HintText;
  1912.   if TmpHint[length(TmpHint)] <> #13 then
  1913.     TmpHint := TmpHint + #13;
  1914.   HintLines := 0;
  1915.   HintW := 0;
  1916.   repeat
  1917.     Inc(HintLines);
  1918.     TmpText := Copy(TmpHint,1,Pos(#13,TmpHint)-1);
  1919.     if HintWin.Canvas.TextWidth(TmpText) + 5 > HintW then
  1920.       HintW := HintWin.Canvas.TextWidth(TmpText) + 5;
  1921.     Delete(TmpHint,1,Pos(#13,TmpHint));
  1922.   until Pos(#13,TmpHint) = 0;
  1923.   { Set the hint height }
  1924.   HintH := (HintWin.Canvas.TextHeight('0') * HintLines) + 5;
  1925.   HintSH := HintWin.Canvas.TextHeight('0') + 5;
  1926.   { Set the delay length }
  1927.   if fHintDelay = 0 then HDelay := Application.HintPause else
  1928.     HDelay := fHintDelay;
  1929.   { Display the hint }
  1930.   HintRect := Rect(Temp.X, Temp.Y + HintSH, Temp.X + HintW, Temp.Y + HintH + HintSH);
  1931.   HintWin.Color := fHintColor;
  1932.   HintWin.Canvas.Font.Assign(fHintFont);
  1933.   HintWin.ActivateHint(HintRect, HintText);
  1934.   { Display the hint window for some time }
  1935.   FirstTickCount := GetTickCount;
  1936.   repeat
  1937.     { If another hint is waiting, get rid of this hint }
  1938.     Application.ProcessMessages;
  1939.     { If the control has been destroyed, this code will safely exit the
  1940.       procedure without causing an access violation }
  1941.     if csDestroying in ComponentState then Exit;
  1942.     { If the parent control has been hidden or the application has terminated
  1943.       the hint shouldn't be shown }
  1944.     if (not Parent.Showing) or (Application.Terminated) then Break;
  1945.     { Otherwise, we deal with the hint in the normal way }
  1946.     if (hSelecting = ypSelecting) or (hWaiting) or (hWaitingToDestroy) then Break;
  1947.   until (GetTickCount - FirstTickCount > HDelay);
  1948.   { Destroy the hint window }
  1949.   HintWin.ReleaseHandle;
  1950.   hUpdating := False;
  1951. end;
  1952.  
  1953. { Thanks to Max Evans for this routine }
  1954. procedure TYearPlanner.WMSize(var Message:TWMSize);
  1955. begin
  1956.   CalculateNavigators;
  1957. end;
  1958.  
  1959. { Thanks to Robert Gesswein for helping with this procedure }
  1960. procedure TYearPlanner.SetColorAtDate(dt: TDateTime; cellColor: TColor; UpdateControl: Boolean);
  1961. var
  1962.   mm,dd,yy: word;
  1963. begin
  1964.   DecodeDate(dt, yy, mm, dd);
  1965.   CellData[mm, dd].CellColor := cellColor;
  1966.   CellData[mm, dd].CustomColor := True;
  1967.   if UpdateControl then Invalidate;
  1968. end;
  1969.  
  1970. procedure TYearPlanner.SetFontAtDate(dt: TDateTime; cellFont: TFont; UpdateControl: Boolean);
  1971. var
  1972.   mm,dd,yy: word;
  1973. begin
  1974.   DecodeDate(dt, yy, mm, dd);
  1975.   CellData[mm, dd].CellFont := cellFont;
  1976.   CellData[mm, dd].CustomFont := True;
  1977.   if UpdateControl then Invalidate;
  1978. end;
  1979.  
  1980. procedure TYearPlanner.SetHintAtDate(dt: TDateTime; cellHint: String; UpdateControl: Boolean);
  1981. var
  1982.   mm,dd,yy: word;
  1983. begin
  1984.   DecodeDate(dt, yy, mm, dd);
  1985.   CellData[mm, dd].CellHint := cellHint;
  1986.   if UpdateControl then Invalidate;
  1987. end;
  1988.  
  1989. {$IFDEF WIN32}
  1990. procedure TYearPlanner.SetImageAtDate(dt: TDateTime; cellImage: Integer; UpdateControl: Boolean);
  1991. var
  1992.   mm,dd,yy: word;
  1993. begin
  1994.   DecodeDate(dt, yy, mm, dd);
  1995.   CellData[mm, dd].CellImage := cellImage;
  1996.   if UpdateControl then Invalidate;
  1997. end;
  1998. {$ENDIF}
  1999.  
  2000. function TYearPlanner.GetCellData(dt: TDateTime): TCellData;
  2001. var
  2002.   mm,dd,yy: word;
  2003. begin
  2004.   DecodeDate(dt, yy, mm, dd);
  2005.   Result := CellData[mm, dd];
  2006. end;
  2007.  
  2008. { Thanks to Paul Bailey, Paul Fisher and Wolf Garber for this routine }
  2009. procedure TYearPlanner.Print;
  2010. var
  2011.   TempCap: array[0..255] of char;
  2012.   pHeight, pWidth: Integer;
  2013.   DrawFlags: Longint;
  2014.   TheRect: TRect;
  2015.   Ratio: Extended;
  2016. begin
  2017.   hPrinting := True;
  2018.   { Work out the page size and margins }
  2019.   with fPrintOptions do
  2020.   begin
  2021.     Printer.Orientation := fPrinterOrientation;
  2022.     { The page width and height exclude the margins }
  2023.     pWidth := Printer.PageWidth - fPrinterLeftMargin - fPrinterRightMargin;
  2024.     pHeight := Printer.PageHeight - fPrinterTopMargin - fPrinterBottomMargin;
  2025.     { Resize the page size based on the reduction ratio }
  2026.     PrinterPageWidth := round(pWidth * (fPrintReductionSize / 100));
  2027.     PrinterPageHeight := round(pHeight * (fPrintReductionSize / 100));
  2028.     {Preserve Aspect Ratio}
  2029.     if PreserveAspect then
  2030.     begin
  2031.       Ratio := Height/Width;
  2032.       PrinterPageHeight := round(Ratio * PrinterPageWidth);
  2033.       if PrinterPageHeight > pHeight then
  2034.       begin
  2035.         PrinterPageWidth:= round(PrinterPageWidth*(pHeight/PrinterPageHeight));
  2036.         PrinterPageHeight:= round(pHeight);
  2037.       end;
  2038.     end;
  2039.     { Set the margins }
  2040.     PrinterLeftMargin := fPrinterLeftMargin;
  2041.     PrinterTopMargin := fPrinterTopMargin;
  2042.     PrinterRightMargin := fPrinterRightMargin;
  2043.     PrinterBottomMargin := fPrinterBottomMargin;
  2044.   end;
  2045.   try
  2046.     Printer.BeginDoc;
  2047.     { Paint the YearPlanner }
  2048.     self.Paint;
  2049.     { Draw the headers and footers }
  2050.     with fPrintOptions, Printer.Canvas do
  2051.     begin
  2052.       { Draw the header }
  2053.       if PrintHeader.Caption <> '' then
  2054.       begin
  2055.         { Setup the header }
  2056.         StrPCopy(TempCap, PrintHeader.Caption);
  2057.         Font := PrintHeader.Font;
  2058.         TheRect := Rect(PrinterLeftMargin, 0, PrinterLeftMargin + pWidth,
  2059.           PrinterTopMargin);
  2060.         { The text is vetically centered in the top margin }
  2061.         DrawFlags := DT_VCENTER or DT_SINGLELINE;
  2062.         { Do the alignment }
  2063.         case PrintHeader.Alignment of
  2064.           taLeftJustify: DrawFlags := DrawFlags or DT_LEFT;
  2065.           taCenter: DrawFlags := DrawFlags or DT_CENTER;
  2066.           taRightJustify: DrawFlags := DrawFlags or DT_RIGHT;
  2067.         end;
  2068.         { Draw the text }
  2069.         DrawText(Handle, TempCap, StrLen(TempCap), TheRect, DrawFlags);
  2070.       end;
  2071.       { Draw the footer }
  2072.       if PrintFooter.Caption <> '' then
  2073.       begin
  2074.         { Setup the footer }
  2075.         StrPCopy(TempCap, PrintFooter.Caption);
  2076.         Font := PrintFooter.Font;
  2077.         TheRect := Rect(PrinterLeftMargin, PrinterTopMargin + pHeight,
  2078.           PrinterLeftMargin + pWidth, PrinterTopMargin + pHeight + PrinterBottomMargin);
  2079.         { The text is vetically centered in the bottom margin }
  2080.         DrawFlags := DT_VCENTER or DT_SINGLELINE;
  2081.         { Do the alignment }
  2082.         case PrintFooter.Alignment of
  2083.           taLeftJustify: DrawFlags := DrawFlags or DT_LEFT;
  2084.           taCenter: DrawFlags := DrawFlags or DT_CENTER;
  2085.           taRightJustify: DrawFlags := DrawFlags or DT_RIGHT;
  2086.         end;
  2087.         { Draw the text }
  2088.         DrawText(Handle, TempCap, StrLen(TempCap), TheRect, DrawFlags);
  2089.       end;
  2090.     end;
  2091.   finally
  2092.     Printer.EndDoc;
  2093.     hPrinting := False;
  2094.   end;
  2095. end;
  2096.  
  2097. { Thanks to Goldschmidt Jean-Jacques for this routine }
  2098. function TYearPlanner.GetStartDate: TDateTime;
  2099. begin
  2100.   GetStartDate := fStartDate;
  2101. end;
  2102.  
  2103. { Thanks to Goldschmidt Jean-Jacques for this routine }
  2104. function TYearPlanner.GetEndDate: TDateTime;
  2105. begin
  2106.   GetEndDate := fEndDate;
  2107. end;
  2108.  
  2109. { Thanks to Goldschmidt Jean-Jacques for this routine }
  2110. function TYearPlanner.IsSelected(date: TDateTime): Boolean;
  2111. var
  2112.   mm,dd,yy: word;
  2113. begin
  2114.   DecodeDate(date, yy, mm, dd);
  2115.   IsSelected := CellData[mm, dd].Selected;
  2116. end;
  2117.  
  2118. { Clear the selection }
  2119. procedure TYearPlanner.ClearSelection;
  2120. begin
  2121.   StDay := 0;
  2122.   StMonth := 0;
  2123.   EnDay := 0;
  2124.   EnMonth := 0;
  2125.   fStartDate := Now;
  2126.   fEndDate := Now;
  2127.   Invalidate;
  2128. end;
  2129.  
  2130. { Manually select a single cell }
  2131. procedure TYearPlanner.SelectCells(sDate, eDate: TDateTime);
  2132. var
  2133.   eD, eM, eY, sD, sM, sY: word;
  2134.   CountX: Integer;
  2135.   tmpDate:  TDateTime;
  2136. begin
  2137.   { We may need to reverse the cell dates }
  2138.   if sDate > eDate then
  2139.   begin
  2140.     tmpDate := sDate;
  2141.     sDate := eDate;
  2142.     eDate := tmpDate;
  2143.   end;
  2144.   { Get the start and end cell dates }
  2145.   DecodeDate(sDate, sY, sM, sD);
  2146.   DecodeDate(eDate, eY, eM, eD);
  2147.   { Find the start date cell }
  2148.   for CountX := 1 to 37 do
  2149.     if StrToIntDef(Cells[CountX, sM],0) = sD then
  2150.     begin
  2151.       { Select the cell }
  2152.       StDay := CountX;
  2153.       StMonth := sM;
  2154.       fStartDate := sDate;
  2155.     end;
  2156.   { Find the end date cell }
  2157.   for CountX := 1 to 37 do
  2158.     if StrToIntDef(Cells[CountX, eM],0) = eD then
  2159.     begin
  2160.       { Select the cell }
  2161.       EnDay := CountX;
  2162.       EnMonth := eM;
  2163.       fEndDate := eDate;
  2164.     end;
  2165.   { Repaint the control }
  2166.   Invalidate;
  2167.   Exit;
  2168. end;
  2169.  
  2170. { Selects a given week }
  2171. procedure TYearPlanner.SelectWeek(aWeek: Integer);
  2172. var
  2173.   eDate, sDate: TDateTime;
  2174. begin
  2175.   { Set the dates }
  2176.   sDate := FindFirstWeek(Year) + ((aWeek - 1) * 7);
  2177.   eDate := sDate + 6;
  2178.   { Select the cells }
  2179.   SelectCells(sDate, eDate);
  2180. end;
  2181.  
  2182. { Thanks to Trev for this routine }
  2183. procedure TYearPlanner.ClearCells;
  2184. var
  2185.   mm, dd: Integer;
  2186. begin
  2187.   for mm := 1 to 12 do
  2188.     for dd := 1 to 31 do
  2189.       with CellData[mm, dd] do
  2190.       begin
  2191.         CellColor := $00000000;
  2192.         CellFont := fDayFont;
  2193.         CellHint := '';
  2194.         CustomColor := False;
  2195.         CustomFont := False;
  2196.         {$IFDEF WIN32}
  2197.         CellImage := -1;
  2198.         {$ENDIF}
  2199.         Tag := -1;
  2200.       end;
  2201.   Invalidate;
  2202. end;
  2203.  
  2204. { Gives you the week number of a specified date. }
  2205. function TYearPlanner.WeekNumber(aDate: TDateTime): Integer;
  2206. var
  2207.   sDay, sMonth, sYear: Word;
  2208. begin
  2209.   { Extract the current year }
  2210.   DecodeDate(aDate, sYear, sMonth, sDay);
  2211.   { We now have the start date of the first week, so find out the difference }
  2212.   Result := Trunc((StrToInt(FloatToStr(aDate - FindFirstWeek(sYear))) / 7) + 1);
  2213. end;
  2214.  
  2215. procedure Register;
  2216. begin
  2217.   RegisterComponents('Samples', [TYearPlanner]);
  2218. end;
  2219.  
  2220. end.
  2221.