[feliz-58]

Código Delphi [-]
procedure Register;

implementation

{ TYearPlanner }

const
  CopyRightStr: PChar = 'TYearPlanner Component v2.71 (22/05/2002)'+#13+#13+
    'By Jonathan Hosking'+#13+#13+'Compiled in '+
    {$IFDEF VER80}  'Delphi 1.0' {$ENDIF}
    {$IFDEF VER90}  'Delphi 2.0' {$ENDIF}
    {$IFDEF VER100} 'Delphi 3.0' {$ENDIF}
    {$IFDEF VER120} 'Delphi 4.0' {$ENDIF}
    {$IFDEF VER130} 'Delphi 5.0' {$ENDIF}
    {$IFDEF VER140} 'Delphi 6.0' {$ENDIF}
    {$IFDEF VER93}  'C++Builder 1.0' {$ENDIF}
    {$IFDEF VER110} 'C++Builder 3.0' {$ENDIF}
    {$IFDEF VER125} 'C++Builder 4.0' {$ENDIF};
  MonthDays: array[1..12] of Integer = (31,28,31,30,31,30,31,31,30,31,30,31);
var
  CopyRightPtr: Pointer;

{ Thanks to Paul Bailey for this procedure }
constructor TPrintOptions.Create(UpdateEvent : TNotifyEvent);
begin
  inherited Create;
  fPreserveAspect:= True;
  fPrinterOrientation := poLandscape;
  fPrintReductionSize :=  100;
  fPrinterLeftMargin := 0;
  fPrinterTopMargin := 0;
  fPrinterRightMargin := 0;
  fPrinterBottomMargin := 0;
  fPrintHeader := TPrintTitle.Create(nil);
  fPrintFooter := TPrintTitle.Create(nil);
end;

{ Thanks to Paul Bailey for this procedure }
destructor TPrintOptions.Destroy;
begin
  fPrintFooter.Free;
  fPrintHeader.Free;
  inherited Destroy;
end;

{ Thanks to Paul Bailey for this procedure }
procedure TPrintTitle.SetAlignment(Val: TAlignment);
begin
  if fAlignment <> Val then
  begin
    fAlignment := Val;
    UpdateControl;
  end;
end;

{ Thanks to Paul Bailey for this procedure }
procedure TPrintTitle.SetCaption(Val: String);
begin
  if fCaption <> Val then
  begin
    fCaption := Val;
    UpdateControl;
  end;
end;

{ Thanks to Paul Bailey and Wolf Garber for this procedure }
procedure TPrintTitle.SetFont(Val: TFont);
begin
  if fFont <> Val then
  begin
    fFont.Assign(Val);
    UpdateControl;
  end;
end;

{ Thanks to Paul Bailey for this procedure }
constructor TPrintTitle.Create(UpdateEvent: TNotifyEvent);
begin
  inherited Create;
  fFont := TFont.Create;
  fCaption := '';
  fAlignment := taLeftJustify;
end;

{ Thanks to Paul Bailey for this procedure }
destructor TPrintTitle.Destroy;
begin
  fFont.Free;
  inherited Destroy;
end;

{ Thanks to Paul Bailey for this procedure }
procedure TPrintTitle.UpdateControl;
begin
  if Assigned(fOnChange) then fOnChange(Self);
end;

{ Gives you the date of the start of the first whole week in a specified
  year.  The start day is determined by the StartDayOfWeek value }
function TYearPlanner.FindFirstWeek(aYear: Word): TDateTime;
var
  sDay, tDay: Integer;
  sDate: TDateTime;
  dateOk: Boolean;
begin
  { We have to find the first whole week, but this depends on the day when
    a week starts }
  dateOk := False;
  sDay := 1;
  while not dateOk do
  begin
    { Find out what day of the week this date is }
    sDate := EncodeDate(aYear, 1, sDay);
    { Convert Delphi day of week to my day of week array }
    tDay := (DayOfWeek(sDate) + 5) mod 7;
    { Is this the start day ? }
    if tDay = ord(fStartDayOfWeek) then dateOk := True;
    { Try the next day }
    inc(sDay);
  end;
  Result := sDate;
end;

{ Procedure to test for a leap year - This is the routine used in Delphi 5,
  but I have used it here as Delphi 1 did not have such a procedure }
function TYearPlanner.IsLeapYear(Year: Word): Boolean;
begin
  Result := (Year mod 4 = 0) and ((Year mod 100 <> 0) or (Year mod 400 = 0));
end;

{ Converts mouse coordinates to cell coordinates }
procedure TYearPlanner.XYToCell(X,Y: Integer;var CellX,CellY: Integer);
begin
  { Work out the column }
  if X < Widths[0] then CellX := 0 else
  begin
    CellX := ((X - Widths[0]) div Widths[1]) + 1;
    if CellX > 37 then CellX := 37;
  end;
  { Work out the row }
  if Y < Heights[0] then CellY := 0 else
  begin
    CellY := ((Y - Heights[0]) div Heights[1]) + 1;
    if CellY > 12 then CellY := 12;
  end;
end;

{ Processes a selection area }
procedure TYearPlanner.ProcessSelection;
var
  sD, eD, sM, eM: Integer;
begin
  { Get the start date from the selected area }
  sD := StDay;
  sM := StMonth;
  eD := EnDay;
  eM := EnMonth;
  if StDay = 0 then Inc(sD);
  if StMonth = 0 then Inc(sM);
  if (StDay > 7) then
    while Cells[sD,sM] = '' do Dec(sD)
  else
    while Cells[sD,sM] = '' do Inc(sD);
  fStartDate := EncodeDate(fYear, sM, StrToInt(Cells[sD,sM]));
  { Get the end date from the selected area }
  if EnDay = 0 then Inc(eD);
  if EnMonth = 0 then Inc(eM);
  if (EnDay > 7) then
    while Cells[eD,eM] = '' do Dec(eD)
  else
    while Cells[eD,eM] = '' do Inc(eD);
  fEndDate := EncodeDate(fYear, eM, StrToInt(Cells[eD,eM]));
end;

{ Reads in the cell data from an open file - Thanks to Jeurgen Jakob and
  Roberto Chieregato for improving this procedure }
procedure TYearPlanner.LoadFromFile(var fFile: File);
var
  fLength, numRead, X, Y: Integer;
begin
  { Read the calender data }
  for X := 1 to 12 do
    for Y := 1 to 31 do
      with CellData[X, Y] do
      begin
        { Read in the cell data }
        BlockRead(fFile, fLength, SizeOf(fLength), numRead);
        if fLength > 0 then
        begin
          {$IFDEF WIN32}
          SetLength(CellHint, fLength);
          {$ENDIF}
          BlockRead(fFile, CellHint[1], fLength, numRead);
        end;
        BlockRead(fFile, CellColor, SizeOf(CellColor), numRead);
        BlockRead(fFile, CellFont, SizeOf(CellFont), numRead);
        BlockRead(fFile, CustomColor, SizeOf(CustomColor), numRead);
        BlockRead(fFile, CustomFont, SizeOf(CustomFont), numRead);
        BlockRead(fFile, CellDate, SizeOf(CellDate), numRead);
        BlockRead(fFile, Selected, SizeOf(Selected), numRead);
        {$IFDEF WIN32}
        BlockRead(fFile, CellImage, SizeOf(CellImage), numRead);
        {$ENDIF}
        BlockRead(fFile, Tag, SizeOf(Tag), numRead);
      end;
end;

{ Reads in the cell data from an open stream - Thanks to Roberto Chieregato for
  improving this procedure }
procedure TYearPlanner.LoadFromStream(var fStream:{$IFDEF USEBLOB}TBlobStream{$ELSE}TStream{$ENDIF});
var
  fLength, X, Y: Integer;
begin
  { Read the calender data }
  for X := 1 to 12 do
    for Y := 1 to 31 do
      with fStream, CellData[X, Y] do
      begin
        { Read in the cell data }
        ReadBuffer(fLength, SizeOf(fLength));
        if fLength > 0 then
        begin
          {$IFDEF WIN32}
          SetLength(CellHint, fLength);
          {$ENDIF}
          ReadBuffer(CellHint[1], fLength);
        end;
        ReadBuffer(CellColor, SizeOf(CellColor));
        ReadBuffer(CellFont, SizeOf(CellFont));
        ReadBuffer(CustomColor, SizeOf(CustomColor));
        ReadBuffer(CustomFont, SizeOf(CustomFont));
        ReadBuffer(CellDate, SizeOf(CellDate));
        ReadBuffer(Selected, SizeOf(Selected));
        {$IFDEF WIN32}
        ReadBuffer(CellImage, SizeOf(CellImage));
        {$ENDIF}
        ReadBuffer(Tag, SizeOf(Tag));
      end;
end;

{ Saves the cell data to an open file - Thanks to Jeurgen Jakob and Roberto
  Chieregato for improving this procedure }
procedure TYearPlanner.SaveToFile(var fFile: File);
var
  fLength, numWritten, X, Y: Integer;
begin
  { Save the calender data }
  for X := 1 to 12 do
    for Y := 1 to 31 do
      with CellData[X, Y] do
      begin
        { Save the cell data }
        fLength := Length(CellHint);
        BlockWrite(fFile, fLength, SizeOf(fLength), numWritten);
        if fLength > 0 then
          BlockWrite(fFile, CellHint[1], fLength, numWritten);
        BlockWrite(fFile, CellColor, SizeOf(CellColor), numWritten);
        BlockWrite(fFile, CellFont, SizeOf(CellFont), numWritten);
        BlockWrite(fFile, CustomColor, SizeOf(CustomColor), numWritten);
        BlockWrite(fFile, CustomFont, SizeOf(CustomFont), numWritten);
        BlockWrite(fFile, CellDate, SizeOf(CellDate), numWritten);
        BlockWrite(fFile, Selected, SizeOf(Selected), numWritten);
        {$IFDEF WIN32}
        BlockWrite(fFile, CellImage, SizeOf(CellImage));
        {$ENDIF}
        BlockWrite(fFile, Tag, SizeOf(Tag), numWritten);
      end;
end;

{ Saves the cell data to an open stream - Thanks to Roberto Chieregato for
  improving this procedure }
procedure TYearPlanner.SaveToStream(var fStream:{$IFDEF USEBLOB}TBlobStream{$ELSE}TStream{$ENDIF});
var
  fLength, X, Y: Integer;
begin
  { Save the calender data }
  for X := 1 to 12 do
    for Y := 1 to 31 do
      with fStream, CellData[X, Y] do
      begin
        { Save the cell data }
        fLength := Length(CellHint);
        WriteBuffer(fLength, SizeOf(fLength));
        if fLength > 0 then
          WriteBuffer(CellHint[1], fLength);
        WriteBuffer(CellColor, SizeOf(CellColor));
        WriteBuffer(CellFont, SizeOf(CellFont));
        WriteBuffer(CustomColor, SizeOf(CustomColor));
        WriteBuffer(CustomFont, SizeOf(CustomFont));
        WriteBuffer(CellDate, SizeOf(CellDate));
        WriteBuffer(Selected, SizeOf(Selected));
        {$IFDEF WIN32}
        WriteBuffer(CellImage, SizeOf(CellImage));
        {$ENDIF}
        WriteBuffer(Tag, SizeOf(Tag));
      end;
end;

{ Thanks to Robert Gesswein for improving this procedure }
procedure TYearPlanner.CalculateCalendar;
var
  I,J: Byte;
  DaysInMonth,StartDay: Integer;
begin
  { Set the Year cell }
  Cells[0, 0] := IntToStr(Self.Year);
  { Clear the cell contents }
  for I := 1 to 37 do
    for J := 1 to 12 do
      Cells[I,J] := '';
  { Setup the cells }
  for I := 1 to 12 do
  begin
    StartDay := DayOfWeek(EncodeDate(Year,I,1));
    StartDay := (StartDay+7-Ord(fStartDayOfWeek)-2) mod 7;
    DaysInMonth := MonthDays[i] + byte(IsLeapYear(Year) and (I = 2));
    for J := 1 to DaysInMonth do Cells[J + StartDay,I] := IntToStr(J);
  end;
end;

{ Thanks to Paul Fisher, Wolfgang Kleinrath and Roberto Chieregato for
  improving this procedure }
procedure TYearPlanner.CalculateData;
var
  I,J: Byte;
  DaysInMonth: Integer;
begin
  { Setup the hints }
  for I := 1 to 12 do
  begin
    DaysInMonth := MonthDays[i] + byte(IsLeapYear(Year) and (I = 2));
    for J := 1 to DaysInMonth do
    begin
      with CellData[I,J] do
      begin
        CellColor := $00000000;
        CellFont := fDayFont;
        CustomColor := False;
        CustomFont := False;
        CellDate := EncodeDate(Year,I,J);
        CellHint := '';
        {$IFDEF WIN32}
        CellImage := -1;
        {$ENDIF}
        Tag := -1;
        Selected := False;
      end;
    end;
  end;
end;

{ Thanks to Max Evans for this routine }
procedure TYearPlanner.CalculateNavigators;
var
  sWidth,sHeight,y: Integer;
begin
  sWidth := GetSystemMetrics(SM_CXHSCROLL);
  sHeight := GetSystemMetrics(SM_CYHSCROLL);
  y := (Heights[0] - sHeight) div 2;
  fYearNavLeft :=  Rect(0 + 1,y,1 + sWidth,y + sHeight);
  fYearNavRight := Rect(Widths[0] - (sWidth + 1),y,Widths[0] - 1,y + sHeight);
end;


{ Thanks to Max Evans, Nacho Urenda and Paul Fisher for helping with this
  procedure }
procedure TYearPlanner.CalculateSizes;
var
  I: Byte;
begin
  { Calculate the cell sizes based on whether or not we are printing or
    using the free space }
  if fUseFreeSpace then
  begin
    Heights[0] := Height - ((Height div 13) * 12);
    Widths[0] := Width - ((Width div 41) * 37);
  end
  else
  begin
    Heights[0] := (Height div 13);
    Widths[0] := (Width div 41) * 4;
  end;
  for I := 1 to 37 do Widths[i] := (Width div 41);
  for I := 1 to 12 do Heights[i] := (Height div 13);
  { Calculate the navigation button sizes }
  CalculateNavigators;
end;

{ Thanks to Max Evans for this routine }
procedure TYearPlanner.CircleToday(Canvas: TCanvas; CircleRect: TRect; const TodayText: String; InnerColor: TColor);
begin
  Canvas.Pen.Color := TodayCircleColour;
  Canvas.Pen.Width := 2;
  Canvas.Brush.Color := InnerColor;
  with CircleRect do
    Canvas.Ellipse(Left, Top, Right, Bottom);
  Canvas.Font.Color := TodayTextColour;
  {$IFDEF WIN32}
  DrawText(Canvas.Handle, PChar(TodayText), -1, CircleRect, DT_VCENTER OR DT_CENTER OR DT_SINGLELINE);
  {$ELSE}
  DrawText(Canvas.Handle, @TodayText[1], -1, CircleRect, DT_VCENTER OR DT_CENTER OR DT_SINGLELINE);
  {$ENDIF}
end;

{ Thanks to Max Evans for this routine }
procedure TYearPlanner.OnGridPenChange(Sender:TObject);
begin
  Invalidate;
end;

{ Thanks to Paolo Prandini, Richard Haven and Robert Gesswein for this
  improved procedure }
procedure TYearPlanner.SetupHeadings;
var
   I,J: Byte;
begin
  for I := 1 to 37 do
  begin
    J := (((I - 1) + (Ord(fStartDayOfWeek))) mod 7) + 2;
    if J = 8 then J := 1;
    Cells[I,0] := ShortDayNames[J][1];
  end;
  for I := 1 to 12 do Cells[0,I] := LongMonthNames[i];
end;

procedure TYearPlanner.SetAllowSelections(Val: Boolean);
begin
  if fAllowSelections <> Val then
  begin
    fAllowSelections := Val;
    Invalidate;
  end;
end;

procedure TYearPlanner.SetDayColor(Val: TColor);
begin
  if fDayColor <> Val then
  begin
    fDayColor := Val;
    Invalidate;
  end;
end;

{ Thanks to Max Evans for this routine }
procedure TYearPlanner.SetDayFont(Val: TFont);
begin
  if fDayFont <> Val then
  begin
    fDayFont.Assign(Val);
    Invalidate;
  end;
end;

{$IFDEF WIN32}