[feliz-58]

Código Delphi [-]
unit Yearplan;
interface

{ If you want to use a blob stream to load and save data, uncomment the next
  line }
{.$DEFINE USEBLOB}

uses
  {$IFDEF WIN32} Windows, {$ELSE} WinTypes, WinProcs, {$ENDIF}
  SysUtils, Messages, Classes, Graphics, Controls, Forms, Dialogs, stdctrls,
  ExtCtrls, Menus, {$IFDEF USEBLOB} DBTables, {$ENDIF} Printers;

type
  { Header and footer class }
  TPrintTitle = class(TPersistent)
  private
    fAlignment: TAlignment;
    fCaption: string;
    fFont: TFont;
    fOnChange: TNotifyEvent;
    procedure SetAlignment(Val: TAlignment);
    procedure SetCaption(Val: String);
    procedure SetFont(Val: TFont);
  public
    constructor Create(UpdateEvent: TNotifyEvent);
    destructor Destroy; override;
    procedure UpdateControl;
  published
    property Alignment: TAlignment read fAlignment write SetAlignment default taLeftJustify;
    property Caption: string read fCaption write SetCaption;
    property Font: TFont read fFont write SetFont;
    property OnChange: TNotifyEvent read fOnChange write fOnChange;
  end;

  { Printer options class }
  TPrintOptions = class(TPersistent)
  private
    fPrinterOrientation: TPrinterOrientation;
    fPrintReductionSize: Integer;
    fPrinterLeftMargin, fPrinterRightMargin: Integer;
    fPrinterBottomMargin, fPrinterTopMargin: Integer;
    fPrintHeader: TPrintTitle;
    fPrintFooter: TPrintTitle;
    fPreserveAspect: Boolean;
  public
    constructor Create(UpdateEvent: TNotifyEvent);
    destructor Destroy; override;
  published
    property LeftMargin: Integer read fPrinterLeftMargin write fPrinterLeftMargin default 0;
    property TopMargin: Integer read fPrinterTopMargin write fPrinterTopMargin default 0;
    property RightMargin: Integer read fPrinterRightMargin write fPrinterRightMargin default 0;
    property BottomMargin: Integer read fPrinterBottomMargin write fPrinterBottomMargin default 0;
    property Orientation: TPrinterOrientation read fPrinterOrientation write fPrinterOrientation default poLandscape;
    property ReductionSize: integer read fPrintReductionSize write fPrintReductionSize default 100;
    property PrintHeader: TPrintTitle read fPrintHeader write fPrintHeader;
    property PrintFooter: TPrintTitle read fPrintFooter write fPrintFooter;
    property PreserveAspect: Boolean read fPreserveAspect write fPreserveAspect default True;
  end;

{ YearPlannner component class }
  TypDOW = (ypMonday,ypTuesday,ypWednesday,ypThursday,ypFriday,ypSaturday,ypSunday);
  TypSel = (ypNotSelecting,ypSelecting,ypSelected);
  TypSelSty = (ypNormal,ypRectangle);
  TYearEvent = procedure(StDays,EnDays,StMonth,EnMonth:integer; StartDate,EndDate: TDateTime) of object;
  { Compiling under Delphi 1 limits us to a 64KB data limit, so the record
    cannot be too long.  Under later versions there are bigger data limits }
  TCellData = record
    CellHint: String{$IFNDEF WIN32}[125]{$ENDIF};
    CellColor: TColor;
    CellFont: TFont;
    CustomColor: Boolean;
    CustomFont: Boolean;
    CellDate: TDateTime;
    Selected: Boolean;
    {$IFDEF WIN32}
    CellImage: Integer;
    {$ENDIF}
    Tag: Longint;
  end;
  TCurrentDate = record
    Day,Month: Byte;
  end;
  TYearPlanAbout = (abNone,abAbout);
  TYearPlanner = class(TCustomControl)
  private
    { Private declarations }
    Cells: Array[0..37,0..12] of string[9];
    Heights: Array[0..12] of Integer;
    Widths: Array[0..37] of Integer;
    cX,cY,OldX,OldY: Integer;
    InDay,InMonth: Integer;
    FirstTickCount: {$IFDEF WIN32}Cardinal{$ELSE}LongInt{$ENDIF};
    hPrinting,hUpdating,hWaiting,hWaitingToDestroy: Boolean;
    hSelecting: TypSel;
    HintDate: TDateTime;
    HintWin: THintWindow;
    PrinterPageHeight, PrinterPageWidth: Integer;
    PrinterLeftMargin, PrinterTopMargin: Integer;
    PrinterRightMargin, PrinterBottomMargin: Integer;
    fStartDate: TDateTime;
    fEndDate: TDateTime;
    fabout: TYearPlanAbout;
    fAllowSelections: Boolean;
    fControl: TBitmap;
    fDayColor: TColor;
    fDayFont: TFont;
    {$IFDEF WIN32}
    fEndEllipsis: Boolean;
    {$ENDIF}
    fFlatCells: Boolean;
    fGridLines: Boolean;
    fGridPen: TPen;
    fHeadingColor: TColor;
    fHintColor: TColor;
    fHintFont: TFont;
    fHintDelay: Integer;
    {$IFDEF WIN32}
    fImages: TImageList;
    {$ENDIF}
    fLongHint: Boolean;
    {$IFDEF WIN32}
    fMonthButtons: Boolean;
    {$ENDIF}
    fMonthColor: TColor;
    fMonthFont: TFont;
    fNoDayColor: TColor;
    fNoDayPriority: Boolean;
    fOnSelectionEnd: TNotifyEvent;
    fOnYearChange: TNotifyEvent;
    fOnYearChanged: TNotifyEvent;
    fOnYearDblClick: TYearEvent;
    fOnYearRightClick: TYearEvent;
    fPrintOptions: TPrintOptions;
    fSelectionColor: TColor;
    fSelectionFont: TFont;
    fSelectionStyle: TypSelSty;
    {$IFDEF WIN32}
    fSeperator: Boolean;
    fSoftBorder: Boolean;
    {$ENDIF}
    fShowDefaultHint: Boolean;
    fShowToday: Boolean;
    fStartDayOfWeek: TypDOW;
    fStretchImages: Boolean;
    fStringList: TStringList;
    fTodayCircleColour: TColor;
    fTodayCircleFilled: Boolean;
    fTodayTextColour: TColor;
    fUseBitmap: Boolean;
    fUseFreeSpace: Boolean;
    fWeekendColor: TColor;
    fWeekendHeadingColor: TColor;
    fYear: Word;
    fYearColor: TColor;
    fYearFont: TFont;
    fYearNavigators: Boolean;
    fYearNavLeft: TRect;
    fYearNavRight: TRect;
    function FindFirstWeek(aYear: Word): TDateTime;
    function IsLeapYear(Year: Word): Boolean;
    procedure ProcessSelection;
    procedure CalculateCalendar;
    procedure CalculateData;
    procedure CalculateNavigators;
    procedure CalculateSizes;
    procedure CircleToday(Canvas: TCanvas; CircleRect: TRect; const TodayText: String; InnerColor: TColor);
    procedure OnGridPenChange(Sender:TObject);
    procedure SetupHeadings;
    procedure SetAllowSelections(Val: Boolean);
    procedure SetDayColor(Val: TColor);
    procedure SetDayFont(Val: TFont);
    {$IFDEF WIN32}
    procedure SetEndEllipsis(Val: Boolean);
    {$ENDIF}
    procedure SetFlatCells(Val: Boolean);
    procedure SetGridLines(Val: Boolean);
    procedure SetGridPen(Val: TPen);
    procedure SetHeadingColor(Val: TColor);
    procedure SetHintColor(Val: TColor);
    procedure SetHintFont(Val: TFont);
    procedure SetHintDelay(Val: Integer);
    procedure SetLongHint(Val: Boolean);
    {$IFDEF WIN32}
    procedure SetMonthButtons(Val: Boolean);
    {$ENDIF}
    procedure SetMonthColor(Val: TColor);
    procedure SetMonthFont(Val: TFont);
    procedure SetNoDayColor(Val: TColor);
    procedure SetNoDayPriority(Val: Boolean);
    procedure SetSelectionColor(Val: TColor);
    procedure SetSelectionFont(Val: TFont);
    procedure SetSelectionStyle(Val: TypSelSty);
    {$IFDEF WIN32}
    procedure SetSeperator(Val: Boolean);
    procedure SetSoftBorder(Val: Boolean);
    {$ENDIF}
    procedure SetShowDefaultHint(Val: Boolean);
    procedure SetShowToday(Val: Boolean);
    procedure SetStartDayOfWeek(Val: TypDOW);
    procedure SetStretchImages(Val: Boolean);
    procedure SetTodayCircleColour(Val: TColor);
    procedure SetTodayCircleFilled(Val: Boolean);
    procedure SetTodayTextColour(Val: TColor);
    procedure SetUseFreeSpace(Val: Boolean);
    procedure SetWeekendColor(Val: TColor);
    procedure SetWeekendHeadingColor(Val: TColor);
    procedure SetYear(Val: Word);
    procedure SetYearColor(Val: TColor);
    procedure SetYearFont(Val:TFont);
    procedure SetYearNavigators(Val: Boolean);
    procedure ShowAbout(Val: TYearPlanAbout);
    procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message wm_EraseBkgnd;
    procedure WMLButtonDblClk(var Message: TWMLButtonDblClk); message wm_LButtonDblClk;
    procedure WMLButtonDown(var Message: TWMLButtonDown); message wm_LButtonDown;
    procedure WMLButtonUp(var Message: TWMLButtonUp); message wm_LButtonUp;
    procedure WMRButtonDown(var Message: TWMRButtonDown); message wm_RButtonDown;
    procedure WMMouseMove(var Message: TWMMouseMove); message wm_MouseMove;
    procedure WMSize(var Message:TWMSize); message wm_Size;
  protected
    { Protected declarations }
    procedure Paint; override;
  public
    { Public declarations }
    CellData: Array[1..12,1..31] of TCellData;
    CurrentDate: TCurrentDate;
    EnDay: Integer;
    EnMonth: Integer;
    StDay: Integer;
    StMonth: Integer;
    StartDate: TDateTime;
    EndDate: TDateTime;
    procedure XYToCell(X,Y: Integer;var CellX,CellY: Integer);
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure LoadFromFile(var fFile: File);
    procedure LoadFromStream(var fStream:{$IFDEF USEBLOB}TBlobStream{$ELSE}TStream{$ENDIF});
    procedure SaveToFile(var fFile: File);
    procedure SaveToStream(var fStream:{$IFDEF USEBLOB}TBlobStream{$ELSE}TStream{$ENDIF});
    procedure SetColorAtDate(dt: TDateTime; cellColor: TColor; UpdateControl: Boolean);
    procedure SetFontAtDate(dt: TDateTime; cellFont: TFont; UpdateControl: Boolean);
    procedure SetHintAtDate(dt: TDateTime; cellHint: String; UpdateControl: Boolean);
    {$IFDEF WIN32}
    procedure SetImageAtDate(dt: TDateTime; cellImage: Integer; UpdateControl: Boolean);
    {$ENDIF}
    function GetCellData(dt: TDateTime): TCellData;
    procedure Print;
    function GetStartDate: TDateTime;
    function GetEndDate: TDateTime;
    function IsSelected(date: TDateTime): Boolean;
    procedure ClearSelection;
    procedure SelectCells(sDate, eDate: TDateTime);
    procedure SelectWeek(aWeek: Integer);
    procedure ClearCells;
    function WeekNumber(aDate: TDateTime): Integer;
  published
    { Published declarations }
    property about: TYearPlanAbout read fAbout write ShowAbout default abNone;
    property Align;
    property AllowSelections: Boolean read fAllowSelections write SetAllowSelections default True;
    property Color;
    property DayColor: TColor read fDayColor write SetDayColor default clWhite;
    property DayFont:TFont read fDayFont write SetDayFont;
    property DragCursor;
    property DragMode;
    property DrawOffScreen: Boolean read fUseBitmap write fUseBitmap default True;
    property Enabled;
    {$IFDEF WIN32}
    property EndEllipsis: Boolean read fEndEllipsis write SetEndEllipsis default False;
    {$ENDIF}
    property FlatCells: Boolean read fFlatCells write SetFlatCells default True;
    property Font;
    property GridLines: Boolean read fGridLines write SetGridLines default True;
    property GridPen:TPen read fGridPen write SetGridPen;
    property HeadingColor: TColor read fHeadingColor write SetHeadingColor default clGray;
    property HintColor: TColor read fHintColor write SetHintColor default clYellow;
    property HintFont: TFont read fHintFont write SetHintFont;
    property HintDelay: Integer read fHintDelay write SetHintDelay default 0;
    {$IFDEF WIN32}
    property Images: TImageList read fImages write fImages;
    {$ENDIF}
    property LongHint: Boolean read fLongHint write SetLongHint default True;
    {$IFDEF WIN32}
    property MonthButtons: Boolean read fMonthButtons write SetMonthButtons default False;
    {$ENDIF}
    property MonthColor: TColor read fMonthColor write SetMonthColor default clGray;
    property MonthFont:TFont read fMonthFont write SetMonthFont;
    property NoDayColor: TColor read fNoDayColor write SetNoDayColor default clSilver;
    property NoDayPriority: Boolean read fNoDayPriority write SetNoDayPriority default False;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property PrintOptions : TPrintOptions read fPrintOptions write fPrintOptions;
    property SelectionColor: TColor read fSelectionColor write SetSelectionColor default clBlue;
    property SelectionFont: TFont read fSelectionFont write SetSelectionFont;
    property SelectionStyle: TypSelSty read fSelectionStyle write SetSelectionStyle default ypNormal;
    {$IFDEF WIN32}
    property Seperator: Boolean read fSeperator write SetSeperator default True;
    property SoftBorder: Boolean read fSoftBorder write SetSoftBorder default False;
    {$ENDIF}
    property ShowDefaultHint: Boolean read fShowDefaultHint write SetShowDefaultHint default True;
    property ShowHint;
    property ShowToday: Boolean read fShowToday write SetShowToday;
    property StartDayOfWeek: TypDOW read fStartDayOfWeek write SetStartDayOfWeek default ypMonday;
    property StretchImages: Boolean read fStretchImages write SetStretchImages default False;
    property TodayCircleColour: TColor read fTodayCircleColour write SetTodayCircleColour;
    property TodayCircleFilled: Boolean read fTodayCircleFilled write SetTodayCircleFilled default False;
    property TodayTextColour: TColor read fTodayTextColour write SetTodayTextColour;
    property UseFreeSpace: Boolean read fUseFreeSpace write SetUseFreeSpace default True;
    property Visible;
    property WeekendColor: TColor read fWeekendColor write SetWeekendColor default clGray;
    property WeekendHeadingColor: TColor read fWeekendHeadingColor write SetWeekendHeadingColor default clSilver;
    property Year: Word read fYear write SetYear;
    property YearColor: TColor read fYearColor write SetYearColor default clGray;
    property YearFont:TFont read fYearFont write SetYearFont;
    property YearNavigators: Boolean read fYearNavigators write SetYearNavigators default True;
    property OnClick;
    property OnDblClick: TYearEvent read fOnYearDblClick write fOnYearDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnMouseRightClick: TYearEvent read fOnYearRightClick write fOnYearRightClick;
    property OnSelectionEnd: TNotifyEvent read fOnSelectionEnd write fOnSelectionEnd;
    property OnYearChange: TNotifyEvent read fOnYearChange write fOnYearChange;
    property OnYearChanged: TNotifyEvent read fOnYearChanged write fOnYearChanged;
  end;