[feliz-58]

Código Delphi [-]
procedure TYearPlanner.SetYearColor(Val: TColor);
begin
  if fYearColor <> Val then
  begin
    fYearColor:= Val;
    Invalidate;
  end;
end;

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

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

procedure TYearPlanner.ShowAbout(Val: TYearPlanAbout);
begin
  if fAbout <> Val then
  begin
    if Val = abNone then fAbout := Val else
    begin
      fAbout := abNone;
      MessageDlg(StrPas(CopyRightStr), mtInformation, [mbOk], 0);
    end;
    Invalidate;
  end;
end;

procedure TYearPlanner.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
  Message.Result := 1;
end;

{ Thanks to Kaj Ekman, Max Evans, Paul Fisher, Rob Schoenaker and Roberto
  Chieregato for improving this routine }
procedure TYearPlanner.Paint;
var
  I,J: Byte;
  T,tH,tW,X,Y: Integer;
  fBorderRect, fCellRect, fSepRect, GridCellRect: TRect;
  fTodayDay, fTodayMonth, fTodayYear: Word;
  GridCol, OldColor: TColor;
  CurrWidth, CurrHeight : Integer;
  CellText: string;
  CellTextLen: Integer;
  TheCanvas: TCanvas;
  DrawDC: HDC;
  SizeRec: tSize;
  {$IFDEF WIN32}
  nXStart, nYStart, tXStart, tYStart: Integer;
  BitmapRect, TempDRect, TempSRect: TRect;
  ImageH, ImageIndex, ImageW: Integer;
  ImageBmp: TPicture;
  {$ELSE}
  bmpNavigator: TBitmap;
  {$ENDIF}

{ This function determines if a cell is selected - Thanks to Roberto Chieregato
  for improving it }
function CellSelected: Boolean;
var
  crDate: TDateTime;
begin
  { By default we assume that the cell is not selected }
  Result := False;
  { We cannot select cells if selections are not allowed }
  if not fAllowSelections then Exit;
  { Is the cell selected ? }
  if SelectionStyle = ypNormal then
  begin
    { With normal selections we check the date range }
    crDate := EncodeDate(Year,J,StrToInt(Cells[I,J]));
    if (crDate >= fStartDate) and (crDate <= fEndDate) then Result := True;
  end
  else
    { With rectangular selections we check the selection coordinates }
    if (I >= StDay) and (I <= EnDay) and (J >= StMonth) and (J <= EnMonth)
      then Result := True;
end;

{ This function determines the font to use for a day cell }
function CellFont: TFont;
var
  Dy,Mn: Byte;
begin
  Result := fDayFont;
  if Cells[I,J] = '' then Exit;
  { It's a calender day, so check for a custom font }
  Dy := StrToInt(Cells[I,J]);
  Mn := J;
  if CellData[Mn,Dy].CustomFont then
  begin
    Result := CellData[Mn,Dy].CellFont;
    Exit;
  end;
  { Check for a selection font }
  if CellSelected then Result := fSelectionFont;
end;

{ This procedure works out the color of a cell - Thanks to Christian Hackbart,
  Max Evans, Paolo Prandini and Robert Gesswein for improving it }
function GridColor: TColor;
var
  Dy,Mn: Byte;
begin
  if I = 0 then
  begin
    if J = 0 then Result:= fYearColor else
      Result := fMonthColor;
    Exit;
  end;
  if (J > 0) and (J < 13) then
    if (Cells[I,J] <> '') then
    begin
      { It's a calender day, so check for a color }
      Dy := StrToInt(Cells[I,J]);
      Mn := J;
      CellData[Mn,Dy].Selected := CellSelected;
      if CellData[Mn,Dy].Selected then
      begin
        { It's a selected cell }
        Result := fSelectionColor;
        Exit;
      end;
      if CellData[Mn,Dy].CustomColor then
      begin
        { Use the custom color }
        Result := CellData[Mn,Dy].CellColor;
        CellData[Mn,Dy].Selected := False;
        Exit;
      end;
    end;
  if J = 13 then Result := fNoDayColor else
  begin
    if (((I+Ord(fStartDayOfWeek) in [0,6,7,13,14,20,21,27,28,34,35,41,42]) or (J = 0))
      and ((not fNoDayPriority) or (Cells[I,J] <> ''))) then
    begin
      { Weekend day or heading }
      Result := fWeekendColor;
      if J = 0 then
        if (I+Ord(fStartDayOfWeek) in [6,7,13,14,20,21,27,28,34,35,41,42]) then
          Result := fWeekendHeadingColor else
            Result := fHeadingColor;
    end
    else
    begin
      { Normal day }
      if Cells[I,J] = '' then Result := fNoDayColor
        else Result := fDayColor;
    end;
  end;
end;

{ Thanks to Roberto Chieregato for this new routine }
{$IFDEF WIN32}
function GridImage: Integer;
var
  Dy,Mn: Byte;
begin
  Result := -1;
  if (Images <> nil) and (J > 0) and (J < 13) and (I > 0) then
    if (Cells[I,J] <> '') then
    begin
      Dy := StrToInt(Cells[I,J]);
      Mn := J;
      Result := CellData[Mn,Dy].CellImage;
    end;
end;
{$ENDIF}

{ Thanks to Max Evans, Paolo Prandini and Rob Schoenaker for helping with
  this routine }
procedure DrawGridLines;
var
  L: Integer;
  LineHeight: Integer;
begin
  with TheCanvas do
  begin
    { Draw the grid }
    Pen.Assign(fGridPen);
    DrawDC := TheCanvas.Handle;
    X := Widths[0] - 1;
    Y := Heights[0] - 1;
    LineHeight := Heights[1] shl 2 + Heights[1] shl 3 + 1;
    for L := 1 to 38 do
    begin
      {$IFDEF WIN32}
      Windows.MoveToEx(DrawDC, X, Y, nil);
      Windows.LineTo(DrawDC, X, Y + LineHeight);
      {$ELSE}
      WinProcs.MoveToEx(DrawDC, X, Y, nil);
      WinProcs.LineTo(DrawDC, X, Y + LineHeight);
      {$ENDIF}
      if L < 38 then
        Inc(X, Widths[L]);
    end;
    for L := 1 to 13 do
    begin
      {$IFDEF WIN32}
      Windows.MoveToEx(DrawDC, Widths[0], Y, nil);
      Windows.LineTo(DrawDC, X, Y);
      {$ELSE}
      WinProcs.MoveToEx(DrawDC, Widths[0], Y, nil);
      WinProcs.LineTo(DrawDC, X, Y);
      {$ENDIF}
      if L < 13 then Inc(Y, Heights[L]);
    end;
  end;
end;

begin
  { Setup the offscreen bitmap }
  CalculateSizes;
  if (fUseBitmap) and not (csDesigning in ComponentState) then
  begin
    fControl.Width := Width;
    fControl.Height := Height;
    TheCanvas := fControl.Canvas;
  end
  else
    TheCanvas := Canvas;
  { Get today's date }
  DecodeDate(Date, fTodayYear, fTodayMonth, fTodayDay);
  with TheCanvas do
  begin
    { Draw the calender cells and text }
    Brush.Style := bsSolid;
    Font := Self.Font;
    DrawDC := TheCanvas.Handle;
    SetBKMode(DrawDC, TRANSPARENT);
    X := 0;
    for I := 0 to 37 do
    begin
      J := 0;
      Y := 0;
      CurrWidth := Widths[i];
      OldColor := GridColor;
      repeat
        T := Y;
        repeat
          Inc(Y,Heights[J]);
          Inc(J);
          GridCol := GridColor;
        until (GridCol <> OldColor) or (J = 13);
        GridCellRect := Rect(X, T, X + CurrWidth, Y);
        Brush.Color := OldColor;
        OldColor := GridCol;
        {$IFDEF WIN32}
        Windows.FillRect(DrawDC, GridCellRect, Brush.Handle);
        {$ELSE}
        WinProcs.FillRect(DrawDC, GridCellRect, Brush.Handle);
        {$ENDIF}
      until
        J = 13;
      Y := 0;
      for J := 0 to 12 do
      begin
        CurrHeight := Heights[J];
        GridCellRect := Rect(X,Y + 1,X + CurrWidth - 1,Y + CurrHeight - 1);
        if (I = 0) or (J = 0) then
        {$IFDEF WIN32}
        fSepRect:= GridCellRect;
        InFlateRect(fSepRect,-10,0);
        if fSeperator then DrawEdge(DrawDC, fSepRect, EDGE_RAISED, BF_BOTTOM);
        { Draw the month buttons and flat cells }
        if (fMonthButtons) and (I = 0) and (J > 0) then
          DrawEdge(DrawDC, GridCellRect, EDGE_RAISED, BF_RECT OR BF_SOFT)
        else
          if not fFlatCells then
            DrawEdge(DrawDC, GridCellRect, BDR_RAISEDINNER, BF_RECT);
        {$ELSE}
        if not fFlatCells then
          Frame3D(TheCanvas,GridCellRect,clBtnHighlight,clBtnShadow,1);
        {$ENDIF}
        {$IFDEF WIN32}
        { Draw the cell images }
        ImageIndex := GridImage;
        If ImageIndex > -1 then
        begin
          ImageBmp := TPicture.Create;
          { Do we want to draw a stretched image ? }
          if fStretchImages then
          begin
            { Stretch the image to fill the cell }
            BitmapRect := Rect(X, Y, X + CurrWidth, Y + CurrHeight);
            Images.GetBitmap(ImageIndex, ImageBmp.Bitmap);
            TheCanvas.StretchDraw(BitmapRect, ImageBmp.Bitmap);
          end
          else
          begin
            { Center the image in the cell }
            Images.GetBitmap(ImageIndex, ImageBmp.Bitmap);
            ImageW := ImageBmp.Bitmap.Width;
            ImageH := ImageBmp.Bitmap.Height;
            { Crop the image so that it is not drawn over other cells }
            if ImageBmp.Width > CurrWidth then
            begin
              { Crop the image width }
              tXStart := (ImageW - CurrWidth) div 2;
              TempSRect := Rect(tXStart, 0, tXStart + CurrWidth, ImageH);
              TempDRect := Rect(0, 0, CurrWidth, ImageH);
              with ImageBmp.Bitmap do Canvas.CopyRect(TempDRect,Canvas,TempSRect);
              ImageBmp.Bitmap.Width := CurrWidth;
              ImageW := ImageBmp.Bitmap.Width;
            end;
            if ImageBmp.Height > CurrHeight then
            begin
              { Crop the image height }
              tYStart := (ImageH - CurrHeight) div 2;
              TempSRect := Rect(0, tYStart, CurrWidth, tYStart + CurrHeight);
              TempDRect := Rect(0, 0, ImageW, CurrHeight);
              with ImageBmp.Bitmap do Canvas.CopyRect(TempDRect,Canvas,TempSRect);
              ImageBmp.Bitmap.Height := CurrHeight;
              ImageH := ImageBmp.Bitmap.Height;
            end;
            { Work out the top left coordinates of the image }
            nXStart := (X + (CurrWidth div 2)) - (ImageW div 2);
            nYStart := (Y + (CurrHeight div 2)) - (ImageH div 2);
            { Draw the image }
            TheCanvas.Draw(nXStart, nYStart, ImageBmp.Bitmap);
          end;
          ImageBmp.Free;
        end
        else
        begin
          {$ENDIF}
          CellText := Cells[I,J];
          CellTextLen := Length(CellText);
          { Select the font to use }
          if CellTextLen <> 0 then
          begin
            if I = 0 then
            begin
              { Month Cell }
              Font := fMonthFont;
              DrawDC := TheCanvas.Handle;
              SetBKMode(DrawDC, TRANSPARENT);
            end;
            if J = 0 then
            begin
              { Day Cell }
              Font := fDayFont;
              DrawDC := TheCanvas.Handle;
              SetBKMode(DrawDC, TRANSPARENT);
            end;
            if (J = 0) and (I = 0) then
            begin
              { Year Cell }
              Font := fYearFont;
              DrawDC := TheCanvas.Handle;
              SetBKMode(DrawDC, TRANSPARENT);
              if fYearNavigators then
              begin
                { Draw the year navigation buttons }
                CalculateNavigators;
                {$IFDEF WIN32}
                if fMonthButtons then
                begin
                  DrawFrameControl(DrawDC, fYearNavLeft, DFC_SCROLL, DFCS_SCROLLLEFT);
                  DrawFrameControl(DrawDC, fYearNavRight, DFC_SCROLL, DFCS_SCROLLRIGHT);
                end
                else
                begin
                  DrawFrameControl(DrawDC, fYearNavLeft, DFC_SCROLL, DFCS_SCROLLLEFT or DFCS_FLAT);
                  DrawFrameControl(DrawDC, fYearNavRight, DFC_SCROLL, DFCS_SCROLLRIGHT or DFCS_FLAT);
                end;
                {$ELSE}
                bmpNavigator := TBitmap.Create;
                try
                  bmpNavigator.Handle := LoadBitmap(0,pchar(obm_LfArrow));
                  BitBlt(DrawDC,fYearNavLeft.Left,fYearNavLeft.Top,fYearNavLeft.Right - fYearNavLeft.Left,
                    fYearNavLeft.Bottom - fYearNavLeft.Top, bmpNavigator.Canvas.Handle,0,0,SrcCopy);
                  bmpNavigator.ReleaseHandle;
                  bmpNavigator.Handle := LoadBitmap(0,pchar(obm_RGArrow));
                  BitBlt(DrawDC,fYearNavRight.Left,fYearNavRight.Top,fYearNavRight.Right - fYearNavRight.Left,
                    fYearNavRight.Bottom - fYearNavRight.Top, bmpNavigator.Canvas.Handle,0,0,SrcCopy)
                finally
                  bmpNavigator.Free;
                end;
                {$ENDIF}
              end;
            end;
            if (J > 0) and (I > 0) then
            begin
              { Normal Cells }
              Font := CellFont;
              DrawDC := TheCanvas.Handle;
              SetBKMode(DrawDC, TRANSPARENT);
            end;
            { Draw the text in the center of the cell }
            {$IFNDEF WIN32}
            GetTextExtentPoint(DrawDC, @CellText[1], CellTextLen, SizeRec);
            {$ELSE}
            GetTextExtentPoint32(DrawDC, PChar(CellText), CellTextLen, SizeRec);
            {$ENDIF}
            tW := (CurrWidth - SizeRec.cx) shr 1;
            tH := (CurrHeight - SizeRec.cy) shr 1;
            {$IFDEF WIN32}
            if fEndEllipsis then
            begin
              fCellRect := Rect(X + tW,Y + tH, (X + tW) + CurrWidth,(Y + tH) + CurrHeight);
              DrawText(DrawDC,PChar(@CellText[1]),-1,fCellRect,DT_VCENTER OR DT_CENTER OR DT_END_ELLIPSIS);
            end
            else
              Windows.TextOut(DrawDC, X + tW, Y + tH, PChar(CellText), CellTextLen);
            {$ELSE}
              WinProcs.TextOut(DrawDC, X + tW, Y + tH, @CellText[1], CellTextLen);
            {$ENDIF}
            if (fShowToday) and (Cells[I, J] = IntToStr(fTodayDay)) and
              (J = fTodayMonth) and (fYear = fTodayYear) then
            begin
              if fTodayCircleFilled then
                CircleToday(TheCanvas, GridCellRect, IntToStr(fTodayDay), fTodayCircleColour)
              else
                CircleToday(TheCanvas, GridCellRect, IntToStr(fTodayDay), GridColor);
            end;
          end;
        {$IFDEF WIN32}
        end;
        {$ENDIF}
        Inc(Y,CurrHeight);
      end;
      Inc(X,CurrWidth);
    end;
    if fGridlines then DrawGridLines;
    {$IFDEF WIN32}
    if fSoftBorder then
    begin
      SetBKMode(DrawDC, OPAQUE);
      fBorderRect:= Rect(0,0,Width,Height);
      DrawEdge(DrawDC,fBorderRect,EDGE_ETCHED,BF_RECT);
    end;
    {$ENDIF}
  end;
  { Now copy the bitmap to the screen }
  if fUseBitmap then
    BitBlt(Canvas.Handle, 0, 0, Width, Height, DrawDC, 0, 0, SRCCOPY);
  { If we are printing, copy the canvas and stretch it to the page }
  if hPrinting then
    StretchBlt(Printer.Canvas.Handle, PrinterLeftMargin, PrinterTopMargin,
      PrinterPageWidth, PrinterPageHeight, Canvas.Handle, 0, 0,
      Width, Height, SRCCOPY);
end;