CD Shareware Magazine 1996 December/CD_shareware_12-96.iso/WIN/Programa/COLCAL.ZIP/COLORC~1.PAS

Pascal/Delphi Source File | 1996-09-08 | 6.1 KB | 228 lines

unit ColorCalendar;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Grids, Calendar;

type
  TDayColorArray = array[1..31] of TColor;
  TDayBrushStyleArray = array[1..31] of TBrushStyle;
  TColorCalendar = class(TCalendar)
  private
    { Private declarations }

    FBaseColor: TColor; {color of days not assigned a color,
                        the inherited Color property gives the color of the cells that don't contain a date}
    FBaseBrushStyle: TBrushStyle; {brush style of days not assigned a brush style}
    FDayColor: TDayColorArray; {color of each day}
    FDayBrushStyle: TDayBrushStyleArray; {brush style of each day}
    function GetDayColor(Index: integer): TColor;
    procedure SetDayColor(Index: integer; Value: TColor);
    procedure SetCellColor(ACol, ARow: integer; ARect: TRect);
    function GetDayBrushStyle(Index: integer): TBrushStyle;
    procedure SetDayBrushStyle(Index: integer; Value: TBrushStyle);
    procedure SetCellBrushStyle(ACol, ARow: integer; ARect: TRect);
    procedure SetBaseColor(Value: TColor);
    procedure SetBaseBrushStyle(Value: TBrushStyle);
    function DayNum(ACol, ARow: Longint): integer; {find the integer day of a cell}
  protected
    { Protected declarations }
    procedure DrawCell(ACol, ARow: LongInt; ARect: TRect; AState: TGridDrawState); override;
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    property DayColor[Index: integer]: TColor read GetDayColor write SetDayColor;
    property DayBrushStyle[Index: integer]: TBrushStyle read GetDayBrushStyle write SetDayBrushStyle;
    procedure NextMonth;
    procedure NextYear;
    procedure PrevMonth;
    procedure PrevYear;
  published
    { Published declarations }
    property BaseColor: TColor read FBaseColor write SetBaseColor default clWhite;
    property BaseBrushStyle: TBrushStyle read FBaseBrushStyle write SetBaseBrushStyle default bsSolid;
    property DefaultDrawing;
  end;

procedure Register;

implementation

constructor TColorCalendar.Create(AOwner: TComponent);
var
  i: integer;
begin
  inherited Create(AOwner);
  FBaseColor := clWhite;
  FBaseBrushStyle := bsSolid;
  for i := 1 to 31 do
  begin
    FDayColor[i] := FBaseColor;
    FDayBrushStyle[i] := FBaseBrushStyle;
  end;
end;

function TColorCalendar.GetDayColor(Index: integer): TColor;
begin
  Result := FDayColor[Index];
end;

procedure TColorCalendar.SetDayColor(Index: integer; Value: TColor);
begin
  FDayColor[Index] := Value;
  Invalidate;
end;

procedure TColorCalendar.DrawCell(ACol, ARow: LongInt; ARect: TRect; AState: TGridDrawState);
var
  TheText: string;
  X, Y: integer;
begin
  inherited DrawCell(ACol, ARow, ARect, AState);
  SetCellColor(ACol, ARow, ARect);
  SetCellBrushStyle(ACol, ARow, ARect);
  TheText := CellText[ACol, ARow];
  Canvas.FillRect(ARect);
  X := ARect.Left + (ARect.Right - ARect.Left - Canvas.TextWidth(TheText)) div 2;
  Y := ARect.Top + (ARect.Bottom - ARect.Top - Canvas.TextHeight(TheText)) div 2;
  Canvas.TextOut(X, Y, TheText);
end;

procedure TColorCalendar.SetCellColor(ACol, ARow: integer; ARect: TRect);
begin
  if DayNum(ACol, ARow) > 0 then
  begin
    Canvas.Brush.Color := FDayColor[DayNum(ACol, ARow)];
    {I just picked clMenuText because, an enhancement would be to have differnt fonts for days}
    Canvas.Font.Color := clMenuText;
  end
  else
  begin
    Canvas.Brush.Color := Color;
    Canvas.Font.Color := clMenuText;
  end;
end;

function TColorCalendar.DayNum(ACol, ARow: Longint): integer;
{This routine finds the integer value of day cell.
If the cell doesn't contain a day then it returns 0}
var
  FirstDate: TDateTime;
  MonthOffset: integer;
begin
  if (ARow > 0) then
  begin
    FirstDate := EncodeDate(Year, Month, 1);
    MonthOffset := 2 - ((DayOfWeek(FirstDate) - StartOfWeek + 7) mod 7); { day of week for 1st of month }
    if MonthOffset = 2 then
      MonthOffset := -5;
    Result := MonthOffset + ACol + (ARow - 1) * 7;
    if Result > DaysThisMonth then
      Result := 0;
  end
  else
    Result := 0;
end;

function TColorCalendar.GetDayBrushStyle(Index: integer): TBrushStyle;
begin
  Result := FDayBrushStyle[Index];
  Invalidate;
end;

procedure TColorCalendar.SetDayBrushStyle(Index: integer; Value: TBrushStyle);
begin
  FDayBrushStyle[Index] := Value;
end;

procedure TColorCalendar.SetCellBrushStyle(ACol, ARow: integer; ARect: TRect);
begin
  if DayNum(ACol, ARow) > 0 then
  begin
    Canvas.Brush.Style := FDayBrushStyle[DayNum(ACol, ARow)];
  end
  else
  begin
    Canvas.Brush.Style := bsSolid;
  end;
end;

procedure TColorCalendar.SetBaseColor(Value: TColor);
var
  i: integer;
begin
  FBaseColor := Value;
  for i := 1 to 31 do
    FDayColor[i] := FBaseColor;
  Invalidate;
end;

procedure TColorCalendar.SetBaseBrushStyle(Value: TBrushStyle);
var
  i: integer;
begin
  FBaseBrushStyle := Value;
  for i := 1 to 31 do
    FDayBrushStyle[i] := FBaseBrushStyle;
  Invalidate;
end;

procedure TColorCalendar.NextMonth;
{It seemed reasonable to me that when a month changed that the day colors should
revert to the base color}
var
  i: integer;
begin
  inherited NextMonth;
  for i := 1 to 31 do
  begin
    FDayColor[i] := FBaseColor;
    FDayBrushStyle[i] := FBaseBrushStyle;
  end;
end;

procedure TColorCalendar.NextYear;
var
  i: integer;
begin
  inherited NextYear;
  for i := 1 to 31 do
  begin
    FDayColor[i] := FBaseColor;
    FDayBrushStyle[i] := FBaseBrushStyle;
  end;
end;

procedure TColorCalendar.PrevMonth;
var
  i: integer;
begin
  inherited PrevMonth;
  for i := 1 to 31 do
  begin
    FDayColor[i] := FBaseColor;
    FDayBrushStyle[i] := FBaseBrushStyle;
  end;
end;

procedure TColorCalendar.PrevYear;
var
  i: integer;
begin
  inherited NextYear;
  for i := 1 to 31 do
  begin
    FDayColor[i] := FBaseColor;
    FDayBrushStyle[i] := FBaseBrushStyle;
  end;
end;

procedure Register;
begin
  RegisterComponents('My Controls', [TColorCalendar]);
end;

end.