[feliz-58]

Código Delphi [-]
{ Thanks to Max Evans for improving this routine }
constructor TYearPlanner.Create(AOwner: TComponent);
var
  Dy,Mn,Yr: Word;
begin
  { Setup the control }
  Inherited Create(AOwner);
  HintWin := THintWindow.Create(Self);
  fStringList := TStringList.Create;
  fPrintOptions := TPrintOptions.Create(nil);
  CopyRightPtr := @CopyRightStr;
  Width := 615;
  Height := 300;
  Color := clGray;
  DecodeDate(Date, Yr, Mn, Dy);
  fAbout := abNone;
  fAllowSelections := True;
  fDayColor := clWhite;
  {$IFDEF WIN32}
  fEndEllipsis := False;
  {$ENDIF}
  fFlatCells := True;
  fGridLines := True;
  fHeadingColor := clGray;
  fHintColor := clYellow;
  fHintDelay := 0;
  fLongHint := True;
  fMonthColor := clGray;
  {$IFDEF WIN32}
  fMonthButtons := False;
  {$ENDIF}
  fNoDayColor := clSilver;
  fNoDayPriority := False;
  fSelectionColor := clBlue;
  fSelectionStyle := ypNormal;
  {$IFDEF WIN32}
  fSeperator := True;
  fSoftBorder := False;
  {$ENDIF}
  fShowDefaultHint := True;
  fStartDayOfWeek := ypMonday;
  fStretchImages := False;
  fTodayCircleColour := clMaroon;
  fTodayCircleFilled := False;
  fTodayTextColour:= clWhite;
  fUseBitmap := True;
  fUseFreeSpace := True;
  fWeekendColor := clGray;
  fWeekendHeadingColor := clSilver;
  fYear := Yr;
  fYearColor:= clGray;
  {$IFDEF WIN32}
  fYearNavigators := True;
  {$ENDIF}
  fStartDate := Now;
  fEndDate := Now;
  hUpdating := False;
  hWaiting := False;
  hWaitingToDestroy := False;
  CurrentDate.Day := 0;
  CurrentDate.Month := 0;
  OldX := -1;
  OldY := -1;
  hPrinting := False;
  hSelecting := ypNotSelecting;
  { Create the off screen bitmap }
  fControl := TBitmap.Create;
  { Create the fonts }
  fDayFont := TFont.Create;
  fHintFont := TFont.Create;
  fMonthFont := TFont.Create;
  fSelectionFont := TFont.Create;
  fYearFont := TFont.Create;
  fGridPen := TPen.Create;
  fGridPen.OnChange:= OnGridPenChange;
  { Setup the calender }
  SetupHeadings;
  CalculateCalendar;
  CalculateData;
  CalculateSizes;
end;

{ Thanks to Max Evans for improving this routine }
destructor TYearPlanner.Destroy;
begin
  { Kill the control }
  fPrintOptions.Free;
  fStringList.Free;
  { Inform the hint window that the control is destroying }
  hWaitingToDestroy := True;
  { If a hint is being displayed, we release the hint window }
  if hUpdating then HintWin.ReleaseHandle;
  { Free the hint window }
  HintWin.Free;
  { Free used bitmap }
  fControl.Free;
  { Free the fonts }
  fGridPen.OnChange:= nil;
  fGridPen.Free;
  fYearFont.Free;
  fSelectionFont.Free;
  fMonthFont.Free;
  fHintFont.Free;
  fDayFont.Free;
  { Here the control is destroyed.  If a hint was being displayed, the hint
    procedure will safely exit by picking up the csDestroying flag in the
    ComponentState property }
  Inherited Destroy;
end;

procedure TYearPlanner.WMLButtonDblClk(var Message: TWMLButtonDblClk);
begin
  { If a selection has been made, and a double click procedure has been set,
    execute it }
  if (hSelecting = ypSelected) and (Assigned(fOnYearDblClick)) then
    fOnYearDblClick(StDay,EnDay,EnMonth,StMonth,fStartDate,fEndDate);
end;

{ Thanks to Martin Roberts, Max Evans, Paul Fisher and Wolf Garber for
  helping with this routine }
procedure TYearPlanner.WMLButtonDown(var Message: TWMLButtonDown);
var
  Pt,Temp: TPoint;
  tX,tY: Integer;
  fOnClick: TNotifyEvent;
begin
  Inherited;
  if fYearNavigators then
  begin
    { Check the navigation buttons }
    GetCursorPos(Pt);
    Pt := ScreenToClient(Pt);
    if PtInRect(fYearNavLeft,Pt) then
    begin
      { User clicked the previous year button }
      Year := Year - 1;
      Invalidate;
      Exit;
    end;
    if PtInRect(fYearNavRight,Pt) then
    begin
      { User clicked the next year button }
      Year := Year + 1;
      Invalidate;
      Exit;
    end;
  end;
  { Check to see if the mouse is over a cell }
  Temp := ClientToScreen(Point(Message.XPos,Message.YPos));
  if not (FindDragTarget(Temp, True) = Self) then Exit;
  XYToCell(Message.XPos,Message.YPos,tX,tY);
  { If we are selecting in date range style, we must select a cell with a date }
  if ((tx = 0) or (ty = 0) or (cells[tx,ty] = '')) and (fSelectionStyle = ypNormal) then
  begin
    ClearSelection;
    Exit;
  end;
  { If the user has assigned an OnClick event, we cannot use selections }
  fOnClick := OnClick;
  if not Assigned(fOnClick) then hSelecting := ypSelecting;
  { Set the initial and start coordinates }
  InDay := tX;
  InMonth := tY;
  StDay := InDay;
  StMonth := InMonth;
  EnDay := InDay;
  EnMonth := InMonth;
  { Set the date range, if we are using date range selection style }
  if fSelectionStyle = ypNormal then
  begin
    fStartDate := EncodeDate(fYear, ty, StrToInt(Cells[tx,ty]));
    fEndDate := fStartDate;
  end;
  { Update the control }
  Invalidate;
end;

{ Thanks to Paul Fisher, Goldschmidt Jean-Jacques and Istvan Mesaros for
  helping with this routine }
procedure TYearPlanner.WMLButtonUp(var Message: TWMLButtonUp);
var
  CountX,CountY: Integer;
begin
  { We cannot allow the user to select a range of cells which do not
    contain dates }
  hSelecting := ypNotSelecting;
  for CountX := StDay to EnDay do
    for CountY := StMonth to EnMonth do
      if Cells[CountX,CountY] <> '' then
        hSelecting := ypSelected;
  { Process the selection coordinates }
  ProcessSelection;
  { Update the start and end date variables }
  StartDate := fStartDate;
  EndDate := fEndDate;
  { Handle an OnSelectionEnd event if one exists }
  if Assigned(fOnSelectionEnd) then fOnSelectionEnd(Self);
  Inherited;
end;

{ Thanks to Paul Fisher for helping with this routine }
procedure TYearPlanner.WMRButtonDown(var Message: TWMRButtonDown);
begin
  Inherited;
  { If a selection has been made, and a right click procedure has been set,
    execute it }
  if (hSelecting = ypSelected) and (Assigned(fOnYearRightClick)) then
    fOnYearRightClick(StDay,EnDay,EnMonth,StMonth,fStartDate, fEndDate);
end;

procedure TYearPlanner.WMMouseMove(var Message: TWMMouseMove);
var
  Temp: TPoint;
  HintText, TmpHint, TmpText: String;
  HintRect: TRect;
  HDelay : {$IFDEF WIN32}Cardinal{$ELSE}LongInt{$ENDIF};
  HintH, HintLines, HintSH, HintW: Integer;
  Dy,Mn: Byte;
  swapTmp:integer;
begin
  { If the control is destroying we cannot continue }
  if hWaitingToDestroy then Exit;
  Inherited;
  { Check to see if the mouse is over a cell }
  Temp := ClientToScreen(Point(Message.XPos,Message.YPos));
  if not (FindDragTarget(Temp, True) = Self) then Exit;
  XYToCell(Message.XPos,Message.YPos,cX,cY);
  { We do not use hints when selecting cells }
  if hSelecting = ypSelecting then
  begin
    { Update the selection coordinates }
    StDay := InDay;
    StMonth := InMonth;
    EnDay := cX;
    EnMonth := cY;
    { Do we need to change the selection coordinates ? }
    if fSelectionStyle = ypNormal then
    begin
      if (StMonth > EnMonth) or ((StMonth = EnMonth) and (StDay > EnDay)) then
      begin
        { With normal selections we reverse the date range }
        swapTmp := StDay;
        StDay := EnDay;
        EnDay := swapTmp;
        swapTmp := StMonth;
        StMonth := EnMonth;
        EnMonth := swapTmp;
      end;
    end
    else
    begin
      { With rectangular selections, we simply switch the coordinates }
      if StDay > EnDay then
      begin
        swapTmp := StDay;
        StDay := EnDay;
        EnDay := swapTmp;
      end;
      if StMonth > EnMonth then
      begin
        swapTmp := StMonth;
        StMonth := EnMonth;
        EnMonth := swapTmp;
      end;
    end;
    { Process the selection coordinates }
    ProcessSelection;
    { Repaint the control }
    Invalidate;
    Exit;
  end;
  { Is this cell a calender day? }
  if ((OldX = cX) and (OldY = cY)) or (cX = 0) or (cY = 0) or
    (Cells[cX,cY] = '') then Exit;
  { Update the current date }
  CurrentDate.Day := StrToInt(Cells[cX,cY]);
  CurrentDate.Month := cY;
  { Now check to see if we can use hints }
  if not (Application.ShowHint and (ShowHint or ParentShowHint)) then Exit;
  { Do we show this hint? }
  if (CellData[cY,CurrentDate.Day].CellHint = '') and (not fShowDefaultHint) then Exit;
  { If a hint is being displayed, we mark a hint status flag to say that
    another hint is waiting }
  if hUpdating then
  begin
    hWaiting := True;
    Exit;
  end;
  { Now we setup the hint }
  OldX := cX;
  OldY := cY;
  Dy := CurrentDate.Day;
  Mn := CurrentDate.Month;
  HintText := CellData[Mn,Dy].CellHint;
  if HintText = '' then
  begin
    { Now we determine whether we display a long or short date }
    if fLongHint then
      HintText := FormatDateTime(LongDateFormat, EncodeDate(Year, Mn, Dy))
    else
      HintText := FormatDateTime(ShortDateFormat, EncodeDate(Year, Mn, Dy));
  end;
  HintDate := CellData[Mn,Dy].CellDate;
  { Set the hint status flags }
  hUpdating := True;
  hWaiting := False;
  { Set the hint width }
  TmpHint := HintText;
  if TmpHint[length(TmpHint)] <> #13 then
    TmpHint := TmpHint + #13;
  HintLines := 0;
  HintW := 0;
  repeat
    Inc(HintLines);
    TmpText := Copy(TmpHint,1,Pos(#13,TmpHint)-1);
    if HintWin.Canvas.TextWidth(TmpText) + 5 > HintW then
      HintW := HintWin.Canvas.TextWidth(TmpText) + 5;
    Delete(TmpHint,1,Pos(#13,TmpHint));
  until Pos(#13,TmpHint) = 0;
  { Set the hint height }
  HintH := (HintWin.Canvas.TextHeight('0') * HintLines) + 3;
  HintSH := HintWin.Canvas.TextHeight('0') + 3;
  { Set the delay length }
  if fHintDelay = 0 then HDelay := Application.HintPause else
    HDelay := fHintDelay;
  { Display the hint }
  HintRect := Rect(Temp.X, Temp.Y + HintSH, Temp.X + HintW, Temp.Y + HintH + HintSH);
  HintWin.Color := fHintColor;
  HintWin.Canvas.Font.Assign(fHintFont);
  HintWin.ActivateHint(HintRect, HintText);
  { Display the hint window for some time }
  FirstTickCount := GetTickCount;
  repeat
    { If another hint is waiting, get rid of this hint }
    Application.ProcessMessages;
    { If the control has been destroyed, this code will safely exit the
      procedure without causing an access violation }
    if csDestroying in ComponentState then Exit;
    { If the parent control has been hidden or the application has terminated
      the hint shouldn't be shown }
    if (not Parent.Showing) or (Application.Terminated) then Break;
    { Otherwise, we deal with the hint in the normal way }
    if (hSelecting = ypSelecting) or (hWaiting) or (hWaitingToDestroy) then Break;
  until (GetTickCount - FirstTickCount > HDelay);
  { Destroy the hint window }
  HintWin.ReleaseHandle;
  hUpdating := False;
end;

{ Thanks to Max Evans for this routine }
procedure TYearPlanner.WMSize(var Message:TWMSize);
begin
  CalculateNavigators;
end;

{ Thanks to Robert Gesswein for helping with this procedure }
procedure TYearPlanner.SetColorAtDate(dt: TDateTime; cellColor: TColor; UpdateControl: Boolean);
var
  mm,dd,yy: word;
begin
  DecodeDate(dt, yy, mm, dd);
  CellData[mm, dd].CellColor := cellColor;
  CellData[mm, dd].CustomColor := True;
  if UpdateControl then Invalidate;
end;

procedure TYearPlanner.SetFontAtDate(dt: TDateTime; cellFont: TFont; UpdateControl: Boolean);
var
  mm,dd,yy: word;
begin
  DecodeDate(dt, yy, mm, dd);
  CellData[mm, dd].CellFont := cellFont;
  CellData[mm, dd].CustomFont := True;
  if UpdateControl then Invalidate;
end;

procedure TYearPlanner.SetHintAtDate(dt: TDateTime; cellHint: String; UpdateControl: Boolean);
var
  mm,dd,yy: word;
begin
  DecodeDate(dt, yy, mm, dd);
  CellData[mm, dd].CellHint := cellHint;
  if UpdateControl then Invalidate;
end;

{$IFDEF WIN32}
procedure TYearPlanner.SetImageAtDate(dt: TDateTime; cellImage: Integer; UpdateControl: Boolean);
var
  mm,dd,yy: word;
begin
  DecodeDate(dt, yy, mm, dd);
  CellData[mm, dd].CellImage := cellImage;
  if UpdateControl then Invalidate;
end;
{$ENDIF}

function TYearPlanner.GetCellData(dt: TDateTime): TCellData;
var
  mm,dd,yy: word;
begin
  DecodeDate(dt, yy, mm, dd);
  Result := CellData[mm, dd];
end;

{ Thanks to Paul Bailey, Paul Fisher and Wolf Garber for this routine }
procedure TYearPlanner.Print;
var
  TempCap: array[0..255] of char;
  pHeight, pWidth: Integer;
  DrawFlags: Longint;
  TheRect: TRect;
  Ratio: Extended;
begin
  hPrinting := True;
  { Work out the page size and margins }
  with fPrintOptions do
  begin
    Printer.Orientation := fPrinterOrientation;
    { The page width and height exclude the margins }
    pWidth := Printer.PageWidth - fPrinterLeftMargin - fPrinterRightMargin;
    pHeight := Printer.PageHeight - fPrinterTopMargin - fPrinterBottomMargin;
    { Resize the page size based on the reduction ratio }
    PrinterPageWidth := round(pWidth * (fPrintReductionSize / 100));
    PrinterPageHeight := round(pHeight * (fPrintReductionSize / 100));
    {Preserve Aspect Ratio}
    if PreserveAspect then
    begin
      Ratio := Height/Width;
      PrinterPageHeight := round(Ratio * PrinterPageWidth);
      if PrinterPageHeight > pHeight then
      begin
        PrinterPageWidth:= round(PrinterPageWidth*(pHeight/PrinterPageHeight));
        PrinterPageHeight:= round(pHeight);
      end;
    end;
    { Set the margins }
    PrinterLeftMargin := fPrinterLeftMargin;
    PrinterTopMargin := fPrinterTopMargin;
    PrinterRightMargin := fPrinterRightMargin;
    PrinterBottomMargin := fPrinterBottomMargin;
  end;
  try
    Printer.BeginDoc;
    { Paint the YearPlanner }
    self.Paint;
    { Draw the headers and footers }
    with fPrintOptions, Printer.Canvas do
    begin
      { Draw the header }
      if PrintHeader.Caption <> '' then
      begin
        { Setup the header }
        StrPCopy(TempCap, PrintHeader.Caption);
        Font := PrintHeader.Font;
        TheRect := Rect(PrinterLeftMargin, 0, PrinterLeftMargin + pWidth,
          PrinterTopMargin);
        { The text is vetically centered in the top margin }
        DrawFlags := DT_VCENTER or DT_SINGLELINE;
        { Do the alignment }
        case PrintHeader.Alignment of
          taLeftJustify: DrawFlags := DrawFlags or DT_LEFT;
          taCenter: DrawFlags := DrawFlags or DT_CENTER;
          taRightJustify: DrawFlags := DrawFlags or DT_RIGHT;
        end;
        { Draw the text }
        DrawText(Handle, TempCap, StrLen(TempCap), TheRect, DrawFlags);
      end;
      { Draw the footer }
      if PrintFooter.Caption <> '' then
      begin
        { Setup the footer }
        StrPCopy(TempCap, PrintFooter.Caption);
        Font := PrintFooter.Font;
        TheRect := Rect(PrinterLeftMargin, PrinterTopMargin + pHeight,
          PrinterLeftMargin + pWidth, PrinterTopMargin + pHeight + PrinterBottomMargin);
        { The text is vetically centered in the bottom margin }
        DrawFlags := DT_VCENTER or DT_SINGLELINE;
        { Do the alignment }
        case PrintFooter.Alignment of
          taLeftJustify: DrawFlags := DrawFlags or DT_LEFT;
          taCenter: DrawFlags := DrawFlags or DT_CENTER;
          taRightJustify: DrawFlags := DrawFlags or DT_RIGHT;
        end;
        { Draw the text }
        DrawText(Handle, TempCap, StrLen(TempCap), TheRect, DrawFlags);
      end;
    end;
  finally
    Printer.EndDoc;
    hPrinting := False;
  end;
end;

{ Thanks to Goldschmidt Jean-Jacques for this routine }
function TYearPlanner.GetStartDate: TDateTime;
begin
  GetStartDate := fStartDate;
end;

{ Thanks to Goldschmidt Jean-Jacques for this routine }
function TYearPlanner.GetEndDate: TDateTime;
begin
  GetEndDate := fEndDate;
end;

{ Thanks to Goldschmidt Jean-Jacques for this routine }
function TYearPlanner.IsSelected(date: TDateTime): Boolean;
var
  mm,dd,yy: word;
begin
  DecodeDate(date, yy, mm, dd);
  IsSelected := CellData[mm, dd].Selected;
end;

{ Clear the selection }
procedure TYearPlanner.ClearSelection;
begin
  StDay := 0;
  StMonth := 0;
  EnDay := 0;
  EnMonth := 0;
  fStartDate := Now;
  fEndDate := Now;
  Invalidate;
end;

{ Manually select a single cell }
procedure TYearPlanner.SelectCells(sDate, eDate: TDateTime);
var
  eD, eM, eY, sD, sM, sY: word;
  CountX: Integer;
  tmpDate:  TDateTime;
begin
  { We may need to reverse the cell dates }
  if sDate > eDate then
  begin
    tmpDate := sDate;
    sDate := eDate;
    eDate := tmpDate;
  end;
  { Get the start and end cell dates }
  DecodeDate(sDate, sY, sM, sD);
  DecodeDate(eDate, eY, eM, eD);
  { Find the start date cell }
  for CountX := 1 to 37 do
    if StrToIntDef(Cells[CountX, sM],0) = sD then
    begin
      { Select the cell }
      StDay := CountX;
      StMonth := sM;
      fStartDate := sDate;
    end;
  { Find the end date cell }
  for CountX := 1 to 37 do
    if StrToIntDef(Cells[CountX, eM],0) = eD then
    begin
      { Select the cell }
      EnDay := CountX;
      EnMonth := eM;
      fEndDate := eDate;
    end;
  { Repaint the control }
  Invalidate;
  Exit;
end;

{ Selects a given week }
procedure TYearPlanner.SelectWeek(aWeek: Integer);
var
  eDate, sDate: TDateTime;
begin
  { Set the dates }
  sDate := FindFirstWeek(Year) + ((aWeek - 1) * 7);
  eDate := sDate + 6;
  { Select the cells }
  SelectCells(sDate, eDate);
end;

{ Thanks to Trev for this routine }
procedure TYearPlanner.ClearCells;
var
  mm, dd: Integer;
begin
  for mm := 1 to 12 do
    for dd := 1 to 31 do
      with CellData[mm, dd] do
      begin
        CellColor := $00000000;
        CellFont := fDayFont;
        CellHint := '';
        CustomColor := False;
        CustomFont := False;
        {$IFDEF WIN32}
        CellImage := -1;
        {$ENDIF}
        Tag := -1;
      end;
  Invalidate;
end;

{ Gives you the week number of a specified date. }
function TYearPlanner.WeekNumber(aDate: TDateTime): Integer;
var
  sDay, sMonth, sYear: Word;
begin
  { Extract the current year }
  DecodeDate(aDate, sYear, sMonth, sDay);
  { We now have the start date of the first week, so find out the difference }
  Result := Trunc((StrToInt(FloatToStr(aDate - FindFirstWeek(sYear))) / 7) + 1);
end;

procedure Register;
begin
  RegisterComponents('Samples', [TYearPlanner]);
end;

end.