obcalendar.pas

还是日历控件。现在网上的日历控件显示的时候都是单个月份。希望有人上传显示全年的！

procedure TOBCalendar.OnGridStartDrag(Sender: TObject;var DragObject: TDragObject);
var
  DragImage : TBitmap;
begin
  inherited;
  ControlStyle := ControlStyle + [csDisplayDragImage];
  DateGrid.ControlStyle := DateGrid.ControlStyle + [csDisplayDragImage];

  DragImage := FDrawBuf.GetBuffer(DateGrid.Col,DateGrid.Row,True);
  DragObject := nil;
  DragObject := TOBDragObject.Create;
  TOBDragObject(DragObject).SetBitmap(DragImage);
end;

function TOBCalendar.GetCellText(X, Y: Integer): String;
begin
  Result := Trim(DateGrid.Cells[X, Y]);
end;

procedure TOBCalendar.GridDrawCell(Sender: TObject; ACol, ARow: Integer;
  Rect: TRect; State: TGridDrawState);
var
  ACanvas : TCanvas;
  ARect : TRect;
  ABuf : TBitmap;
  AText : String;
  Selected : Boolean;
  Handled : Boolean;
begin
  Handled := False;
  ACanvas := DateGrid.Canvas;
  Selected := (ACol=DateGrid.Col) and (ARow=DateGrid.Row);
  ABuf := FDrawBuf.GetBuffer(ACol,ARow,Selected);
  AText := GetCellText(ACol,ARow);

  ARect.Left := 0;
  ARect.Top := 0;
  ARect.Right := WidthOf(Rect);
  ARect.Bottom := HeightOf(Rect);

  if ARow = 0 then
  begin
    if (ABuf.Width <> WidthOf(Rect)) or (ABuf.Height <> HeightOf(Rect)) then
    begin
      ABuf.Width := WidthOf(Rect);
      ABuf.Height := HeightOf(Rect);
      GradientFillRect(ABuf.Canvas,ARect,ColorDef.WeekBackGroupColorStart,
        ColorDef.WeekBackGroupColorEnd,fdTopToBottom,HeightOf(ARect));

      ABuf.Canvas.Brush.Style := bsClear;
      ABuf.Canvas.Font.Name := Font.Name;
      ABuf.Canvas.Font.Size := Font.Size;
      DrawText(ABuf.Canvas.Handle,pChar(AText),-1,ARect,DT_CENTER+DT_VCENTER+DT_SINGLELINE);
    end;
  end else
  begin
    if (ABuf.Width <> WidthOf(Rect)) or (ABuf.Height <> HeightOf(Rect)) then
    begin
      ABuf.Width := WidthOf(Rect);
      ABuf.Height := HeightOf(Rect);

      if Trim(AText) = '' then
      begin
        if Assigned(FOnCustomDrawCell) then FOnCustomDrawCell(ABuf.Canvas,ACol,ARow,StrToIntDef(AText,-1),ARect,Selected,Handled);

        if not Handled then
        begin
          ABuf.Canvas.Brush.Color := ColorDef.NullDateBackColor;
          ABuf.Canvas.FillRect(ARect);
        end;
      end else
      begin
        if Selected then
        begin
          ABuf.Canvas.Brush.Color := clWindow;
          ABuf.Canvas.FillRect(Classes.Rect(ARect.Left,ARect.Top,ARect.Right,ARect.Bottom));

          GradientFillRect(ABuf.Canvas,Classes.Rect(ARect.Left,ARect.Top,ARect.Right,ARect.Bottom),
            ColorDef.SelDateFillColorStart,ColorDef.SelDateFillColorEnd,fdTopToBottom,HeightOf(ARect));
          ABuf.Canvas.Brush.Style := bsClear;
          ABuf.Canvas.Font.Color := ColorDef.SelDateFontColor;
        end else
        begin
          ABuf.Canvas.Brush.Color := clWindow;
          ABuf.Canvas.FillRect(Classes.Rect(ARect.Left,ARect.Top,ARect.Right,ARect.Bottom));
          ABuf.Canvas.Brush.Style := bsClear;
        end;

        ABuf.Canvas.Font.Name := Font.Name;
        ABuf.Canvas.Font.Size := Font.Size;
        ABuf.Canvas.TextOut(ARect.Left+2,ARect.Top+1,AText);

        if Assigned(FOnCustomDrawCell) then FOnCustomDrawCell(ABuf.Canvas,ACol,ARow,StrToIntDef(AText,-1),ARect,Selected,Handled);
      end;
    end;
  end;

  ACanvas.Draw(Rect.Left,Rect.Top,ABuf);
end;

procedure TOBCalendar.GridSelectCell(Sender: TObject; ACol, ARow: Integer;
  var CanSelect: Boolean);
begin
  CanSelect := (DateGrid.Cells[ACol,ARow] <> '') and (ARow <> 0);

  if CanSelect then
  begin
    FDate := EncodeDate(YearOf(FDate),MonthOf(FDate),StrToInt(DateGrid.Cells[ACol,ARow]));
    if Assigned(FOnDateChanged) then FOnDateChanged(Self);
  end;
end;

procedure TOBCalendar.Loaded;
begin
  inherited;
  Resize;
  FDate := SysUtils.Date();
  SelToDayCell;
end;

procedure TOBCalendar.PaintWindow(DC: HDC);
begin
  inherited;
  DateLabel.Font.Name := Font.Name;
  DateLabel.Font.Size := Font.Size;
end;

procedure TOBCalendar.ReBuilderCalcContent;
const
  WeekStrs : array[0..6] of string = ('日','一','二','三','四','五','六');
var
  i, j : Integer;
  Week : Integer;
  Days : Integer;
begin
  for i := 0 to 6 do
  begin
    DateGrid.Cells[i,0] := WeekStrs[i];
  end;

  Days := DaysInMonth(FDate);
  Week := DayOfWeek(EncodeDate(YearOf(FDate),MonthOf(FDate),1));
  for j := 1 to 6 do
  begin
    for i := 0 to 6 do
    begin
      if (((j-1) * 7 + i) < Week - 1) or (((j-1) * 7 + i) - Week + 2 > Days) then
      begin
        DateGrid.Cells[i,j] := '';
      end else
      begin
        DateGrid.Cells[i,j] := IntToStr(((j-1) * 7 + i) - Week + 2);
      end;
    end;
  end;
end;

procedure TOBCalendar.Resize;
var
  i : Integer;
begin
  inherited;
  if DateGrid <> nil then
  begin
    DateLabel.Width := Width - 15 * 2;
    if BtnNextMonth <> nil then
    begin
      BtnNextMonth.Left := Width - 20;
    end;

    DateGrid.Width := Width;
    DateGrid.Height := Height - 30;
    for i := 0 to 5 do
    begin
      DateGrid.ColWidths[i] := (DateGrid.Width - 6) div 7;
      DateGrid.RowHeights[i] := (DateGrid.Height - 6) div 7;
    end;
    DateGrid.ColWidths[6] := DateGrid.Width - (DateGrid.Width - 6) div 7 * 6 - 10;
    DateGrid.RowHeights[6] := DateGrid.Height - (DateGrid.Height - 6) div 7 * 6 -10;
    FDrawBuf.ResetAllBuffer;
    Invalidate;
  end;
end;

procedure TOBCalendar.SelToDayCell;
var
  i , j : Integer;
  RePaintRect : TRect;
begin
  for j := 1 to 6 do
  begin
    for i := 0 to 6 do
    begin
      if DateGrid.Cells[i,j] = IntToStr(DayOf(FDate)) then
      begin
        DateGrid.Col := i;
        DateGrid.Row := j;
        RePaintRect := DateGrid.CellRect(i,j);
        InvalidateRect(DateGrid.Handle,@RePaintRect,False);
        Exit;
      end;
    end;
  end;
end;

procedure TOBCalendar.SetCalcStyle(const Value: TCalcStyles);
begin
  FCalcStyle := Value;
  case Value of
    csWindows :
    begin
      Color := clBtnShadow;
      DateLabel.Font.Color := clWhite;
      ColorDef.WeekBackGroupColorStart := clBtnFace;
      ColorDef.WeekBackGroupColorEnd := clWindow;
      ColorDef.NullDateBackColor := $00F5F5F5;
      ColorDef.SelDateFillColorStart := $00EBDAC7;
      ColorDef.SelDateFillColorEnd := $00FBF7F2;
      ColorDef.SelDateFontColor := clWindowText;

      if BtnPriorMonth <> nil then
      begin
        BtnPriorMonth.Font.Color := clBtnFace;
        BtnNextMonth.Font.Color := clBtnFace;
      end;
    end;
  end;
end;

procedure TOBCalendar.SetDate(const Value: TDate);
begin
  if (YearOf(FDate) <> YearOf(Value)) or
     (MonthOf(FDate) <> MonthOf(Value)) then
  begin
    FDate := Value;
    ReBuilderCalcContent;
    FDrawBuf.ResetAllBuffer;
    SelToDayCell;
    DateLabel.Caption := FormatDateTime('YYYY''年''MM''月''',FDate);
  end else
  begin
    FDate := Value;
    SelToDayCell;
  end;

  if Assigned(FOnDateChanged) then FOnDateChanged(Self);
end;

procedure TOBCalendar.SetDragMode(const Value: TDragMode);
begin
  if DateGrid.DragMode <> Value then
  begin
    DateGrid.DragMode := Value;
  end;
end;

function TOBCalendar.GetDragMode: TDragMode;
begin
  Result := DateGrid.DragMode;
end;

procedure TOBCalendar.InvalidateAllCell;
begin
  FDrawBuf.ResetAllBuffer;
  Invalidate;
end;

procedure TOBCalendar.InvalidateCell(X, Y: Integer);
var
  RePaintRect : TRect;
begin
  FDrawBuf.ResetBuffer(X,Y,False);
  FDrawBuf.ResetBuffer(X,Y,True);
  RePaintRect := DateGrid.CellRect(X,Y);
  InvalidateRect(DateGrid.Handle,@RePaintRect,False);
end;

procedure TOBCalendar.InvalidateDay(Day: Integer);
var
  i , j : Integer;
begin
  for j := 1 to 6 do
  begin
    for i := 0 to 6 do
    begin
      if DateGrid.Cells[i,j] = IntToStr(Day) then
      begin
        InvalidateCell(i,j);
        Exit;
      end;
    end;
  end;
end;

function TOBCalendar.GetDayFromXYMousePos(X, Y: Integer): Integer;
var
  ACol, ARow : Integer;
begin
  Result := -1;
  if Y > 30 then
  begin
    DateGrid.MouseToCell(X, Y - 30, ACol, ARow);
    if (ACol <> -1) and (ARow <> -1) then
       Result := StrToIntDef(DateGrid.Cells[ACol,ARow],-1);
  end;
end;

procedure TOBCalendar.GridMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
var
  PT : TPoint;
begin
  PT.X := X; PT.Y := Y;
  PT := DateGrid.ClientToParent(PT);
  if Assigned(OnMouseMove) then OnMouseMove(Self,Shift,PT.X,PT.Y); 
end;

procedure TOBCalendar.GridDBClick(Sender: TObject);
begin
  if Assigned(OnDblClick) then OnDblClick(Self); 
end;

{ TOBDrawBuffer }

constructor TOBDrawBuffer.Create(AOwner: TComponent);
var
  i : Integer;
begin
  inherited;
  for i := 0 to 48 do
  begin
    FBuffer1[i] := nil;
    FBuffer1[i] := TBitmap.Create;
    FBuffer1[i].Width := 1;
    FBuffer1[i].Height := 1;
    FBuffer1[i].PixelFormat := pf24bit;

    FBuffer2[i] := nil;
    FBuffer2[i] := TBitmap.Create;
    FBuffer2[i].Width := 1;
    FBuffer2[i].Height := 1;
    FBuffer2[i].PixelFormat := pf24bit;
  end;
end;

destructor TOBDrawBuffer.Destroy;
var
  i : Integer;
begin
  for i := 0 to 48 do
  begin
    if FBuffer1[i] <> nil then FBuffer1[i].Free;
    if FBuffer2[i] <> nil then FBuffer2[i].Free;
  end;
  inherited;
end;

function TOBDrawBuffer.GetBuffer(X, Y : Integer;Selected : Boolean): TBitmap;
var
  Index : Integer;
begin
  Index := Y * 7 + X;
  if Selected
     then Result := FBuffer2[Index]
     else Result := FBuffer1[Index];
end;

procedure TOBDrawBuffer.ResetAllBuffer;
var
  i : Integer;
begin
  inherited;
  for i := 0 to 48 do
  begin
    FBuffer1[i].Width := 1;
    FBuffer1[i].Height := 1;

    FBuffer2[i].Width := 1;
    FBuffer2[i].Height := 1;
  end;
end;

procedure TOBDrawBuffer.ResetBuffer(X, Y: Integer;Selected : Boolean);
var
  Index : Integer;
begin
  Index := Y * 7 + X;
  if Selected
     then FBuffer2[Index].Width := 1
     else FBuffer1[Index].Width := 1;
end;

end.