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