wqcalendar.pas

一款不错的年历控件

unit WqCalendar;

interface

uses Classes, Controls, Messages, Windows, Forms, Graphics, StdCtrls,
  Grids, SysUtils;

type
  TDayOfWeek = 0..6;

  TWqCalendar = class(TCustomGrid)
  private
    FDate: TDateTime;
    FMonthOffset: Integer;
    FOnChange: TNotifyEvent;
    FReadOnly: Boolean;
    FStartOfWeek: TDayOfWeek;
    FUpdating: Boolean;
    FUseCurrentDate: Boolean;
    function GetCellText(ACol, ARow: Integer): string;
    function GetDateElement(Index: Integer): Integer;
    procedure SeTWqCalendarDate(Value: TDateTime);
    procedure SetDateElement(Index: Integer; Value: Integer);
    procedure SetStartOfWeek(Value: TDayOfWeek);
    procedure SetUseCurrentDate(Value: Boolean);
    function StoreCalendarDate: Boolean;
  protected
    procedure Change; dynamic;
    procedure ChangeMonth(Delta: Integer);
    procedure Click; override;
    function DaysPerMonth(AYear, AMonth: Integer): Integer; virtual;
    function DaysThisMonth: Integer; virtual;
    procedure DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState); override;
    function IsLeapYear(AYear: Integer): Boolean; virtual;
    function SelectCell(ACol, ARow: Longint): Boolean; override;
    procedure WMSize(var Message: TWMSize); message WM_SIZE;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property CalendarDate: TDateTime  read FDate write SeTWqCalendarDate stored StoreCalendarDate;
    property CellText[ACol, ARow: Integer]: string read GetCellText;
    procedure NextMonth;
    procedure NextYear;
    procedure PrevMonth;
    procedure PrevYear;
    function YearCyclical:String;
    function MonthCyclical:String;
    function DayCyclical:String;
    function HourCyclical(ADate :TDateTime):String;
    function Animals:String;
    function SolarTerm:String;
    function HolDay:String;
    function NLYear:Integer;
    function NLMonth:Integer;
    function NLDay:Integer;
    procedure UpdateCalendar; virtual;
  published
    property Align;
    property Anchors;
    property BorderStyle;
    property Color;
    property Constraints;
    property Ctl3D;
    property Day: Integer index 3  read GetDateElement write SetDateElement stored False;
    property DragCursor;
    property DragKind;
    property DragMode;
    property Enabled;
    property Font;
    property GridLineWidth;
    property Month: Integer index 2  read GetDateElement write SetDateElement stored False;
    property ParentColor;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ReadOnly: Boolean read FReadOnly write FReadOnly default False;
    property ShowHint;
    property StartOfWeek: TDayOfWeek read FStartOfWeek write SetStartOfWeek;
    property TabOrder;
    property TabStop;
    property UseCurrentDate: Boolean read FUseCurrentDate write SetUseCurrentDate default True;
    property Visible;
    property Year: Integer index 1  read GetDateElement write SetDateElement stored False;
    property OnClick;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDock;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnStartDock;
    property OnStartDrag;
  end;

procedure Register;

implementation

uses DateCn;

var
  DrawBitmap: TBitmap;
  UserCount: Integer;

procedure UsesBitmap;
begin
  if UserCount = 0 then
    DrawBitmap := TBitmap.Create;
  Inc(UserCount);
end;

procedure ReleaseBitmap;
begin
  Dec(UserCount);
  if UserCount = 0 then DrawBitmap.Free;
end;

function Max(X, Y: Integer): Integer;
begin
  Result := Y;
  if X > Y then Result := X;
end;

procedure WriteText(ACanvas: TCanvas; ARect: TRect; DX, DY ,DT: Integer;
  const Text: string; Alignment: TAlignment; MultiRows : boolean);
const
  AlignFlags : array [TAlignment] of Integer =
    ( DT_LEFT  or DT_WORDBREAK or DT_EXPANDTABS or DT_NOPREFIX,
      DT_RIGHT  or DT_WORDBREAK or DT_EXPANDTABS or DT_NOPREFIX,
      DT_CENTER  or DT_WORDBREAK or DT_EXPANDTABS or DT_NOPREFIX );
var
  B, R: TRect;
  I: Cardinal;
  Align : integer;
begin
  Align := DT_VCENTER;
  if not ( MultiRows ) then
    Align := Align + DT_WORDBREAK;

  I := ColorToRGB(ACanvas.Brush.Color);
  if GetNearestColor(ACanvas.Handle, I) = I then
  begin                       { Use ExtTextOut for solid colors }
    ACanvas.FillRect(ARect);
    with ARect do begin
      Left := Left + DX;
      Right := Right - DX;
      Top := Top + DT;
    end;
    DrawText(ACanvas.Handle, PChar(Text), Length(Text), ARect,
             AlignFlags[Alignment] + Align);
  end
  else begin                  { Use FillRect and Drawtext for dithered colors }
    DrawBitmap.Canvas.Lock;
    try
      with DrawBitmap, ARect do { Use offscreen bitmap to eliminate flicker and }
      begin                     { brush origin tics in painting / scrolling.    }
        Width := Max(Width, Right - Left);
        Height := Max(Height, Bottom - Top);
        R := Rect( DX, DY, Right - Left - 1, Bottom - Top);
        B := Rect(0, 0, Right - Left, Bottom - Top);
      end;
      with DrawBitmap.Canvas do
      begin
        Font := ACanvas.Font;
        Font.Color := ACanvas.Font.Color;
        Brush := ACanvas.Brush;
        Brush.Style := bsSolid;
        FillRect(B);
        SetBkMode(Handle, TRANSPARENT);
        DrawText(Handle, PChar(Text), Length(Text), R,
            AlignFlags[Alignment] + Align );
      end;
      ACanvas.CopyRect(ARect, DrawBitmap.Canvas, B);
    finally
      DrawBitmap.Canvas.Unlock;
    end;
  end;
end;


constructor TWqCalendar.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  { defaults }
  //
  UsesBitmap;
  //
  FUseCurrentDate := True;
  FixedCols := 0;
  FixedRows := 1;
  ColCount := 7;
  RowCount := 7;
  Height := 240;
  Width := 300;
  ScrollBars := ssNone;
  Options := Options - [goRangeSelect] + [goDrawFocusSelected];
  Font.Name := '细明体';
  FDate := Date;
  UpdateCalendar;
end;

destructor TWqCalendar.Destroy;
begin
 ReleaseBitmap;
 inherited Destroy;
end;

procedure TWqCalendar.Change;
begin
  if Assigned(FOnChange) then FOnChange(Self);
end;

procedure TWqCalendar.Click;
var
  TheCellText: string;
begin
  inherited Click;
  TheCellText := CellText[Col, Row];
  if TheCellText <> '' then Day := StrToInt(TheCellText);
end;

function TWqCalendar.IsLeapYear(AYear: Integer): Boolean;
begin
  Result := (AYear mod 4 = 0) and ((AYear mod 100 <> 0) or (AYear mod 400 = 0));
end;

function TWqCalendar.DaysPerMonth(AYear, AMonth: Integer): Integer;
const
  DaysInMonth: array[1..12] of Integer = (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
begin
  Result := DaysInMonth[AMonth];
  if (AMonth = 2) and IsLeapYear(AYear) then Inc(Result); { leap-year Feb is special }
end;

function TWqCalendar.DaysThisMonth: Integer;
begin
  Result := DaysPerMonth(Year, Month);
end;

procedure TWqCalendar.DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState);
var
  TheText,NText,HolDay    : string;
  TheDate           : TDate;
  R                 : TRect;
  GColor,NColor     : TColor;
begin
  TheText := CellText [ACol, ARow];
  NText := '';
  HolDay := '';

  GColor := Canvas.Font.Color;
  NColor := Canvas.Font.Color;

  if (TheText <> '') and (ARow > 0) and
     (Year >= 1901) and (Year <= 2050) then
    begin
      TheDate := EncodeDate (Year, Month, StrToInt (TheText));
      if (DayOfWeek (TheDate) = 1) then
        GColor := clRed;
      if (DayOfWeek (TheDate) = 7) then
        GColor := $0000BF00;;
      if (CnDayOfDate (TheDate) = 1) then
        begin
          NText := CnMonthOfDateCH (TheDate);
          NColor := clRed;

        end
      else
        begin
          NText := CnDayOfDateCH(TheDate);
        end;
      if (CnMonthOfDate(TheDate) =1) and (CnDayOfDate(TheDate) in [2,3]) then
        NColor := clRed;

      //  HolDay := GetLunarHolDay(TheDate);
//      HolDay := CnDayOfDateJr(TheDate);
      HolDay := GetSolarTerm(TheDate);
      if HolDay <> '' then
      begin
        NColor := clRed;
      end;

      if HolDay <> '' then NText := HolDay;

    end;

  with ARect,Canvas do begin
    if  ARow = 0 then
      begin
      Canvas.Font.Size := 9;

      WriteText(Canvas, ARect, 2,2,(ARect.Bottom - ARect.Top - TextHeight(TheText)) div 2, TheText, taCenter, True);
      end
    else
      begin
      Canvas.Font.Size := 14;
      Canvas.Font.Color := GColor;
      WriteText(Canvas, ARect, 2,2,0, TheText, taCenter, True);
      R := ARect;
      R.Top := R.Top + Round(((R.bottom - R.Top + 1) / 2)) + 2;
      Canvas.Font.Size := 9;
      Canvas.Font.Color := NColor;
      WriteText(Canvas, R, 2,2,0, NText, taCenter, True);
      end;
  end;

end;

function TWqCalendar.GetCellText(ACol, ARow: Integer): string;
var
  DayNum: Integer;
begin
  if ARow = 0 then  { day names at tops of columns }
    Result := ShortDayNames[(StartOfWeek + ACol) mod 7 + 1]
  else
  begin
    DayNum := FMonthOffset + ACol + (ARow - 1) * 7;
    if (DayNum < 1) or (DayNum > DaysThisMonth) then Result := ''
    else Result := IntToStr(DayNum);
  end;
end;

function TWqCalendar.SelectCell(ACol, ARow: Longint): Boolean;
begin
  if ((not FUpdating) and FReadOnly) or (CellText[ACol, ARow] = '') then
    Result := False
  else Result := inherited SelectCell(ACol, ARow);
end;

procedure TWqCalendar.SeTWqCalendarDate(Value: TDateTime);
begin
  FDate := Value;
//  UpdateCalendar;
  Change;
end;

function TWqCalendar.StoreCalendarDate: Boolean;
begin
  Result := not FUseCurrentDate;
end;

function TWqCalendar.GetDateElement(Index: Integer): Integer;
var
  AYear, AMonth, ADay: Word;
begin
  DecodeDate(FDate, AYear, AMonth, ADay);
  case Index of
    1: Result := AYear;
    2: Result := AMonth;
    3: Result := ADay;
    else Result := -1;
  end;
end;

procedure TWqCalendar.SetDateElement(Index: Integer; Value: Integer);
var
  AYear, AMonth, ADay: Word;
begin
  if Value > 0 then
  begin
    DecodeDate(FDate, AYear, AMonth, ADay);
    case Index of
      1: if AYear <> Value then AYear := Value else Exit;
      2: begin
          if (Value <= 12) and (Value <> AMonth) then AMonth := Value else Exit;
          if Day > DaysPerMonth(AYear,AMonth) then ADay := DaysPerMonth(AYear,AMonth);
         end;
      3: if (Value <= DaysThisMonth) and (Value <> ADay) then ADay := Value else Exit;
      else Exit;
    end;


    FDate := EncodeDate(AYear, AMonth, ADay);
    FUseCurrentDate := False;

    if Index in [1,2] then
      UpdateCalendar;
    Change;
  end;
end;

procedure TWqCalendar.SetStartOfWeek(Value: TDayOfWeek);
begin
  if Value <> FStartOfWeek then
  begin
    FStartOfWeek := Value;
    UpdateCalendar;
  end;
end;

procedure TWqCalendar.SetUseCurrentDate(Value: Boolean);
begin
  if Value <> FUseCurrentDate then
  begin
    FUseCurrentDate := Value;
    if Value then
    begin
      FDate := Date; { use the current date, then }
      UpdateCalendar;
    end;
  end;
end;

{ Given a value of 1 or -1, moves to Next or Prev month accordingly }
procedure TWqCalendar.ChangeMonth(Delta: Integer);
var
  AYear, AMonth, ADay: Word;
  NewDate: TDateTime;
  CurDay: Integer;
begin
  DecodeDate(FDate, AYear, AMonth, ADay);
  CurDay := ADay;
  if Delta > 0 then ADay := DaysPerMonth(AYear, AMonth)
  else ADay := 1;
  NewDate := EncodeDate(AYear, AMonth, ADay);
  NewDate := NewDate + Delta;
  DecodeDate(NewDate, AYear, AMonth, ADay);
  if DaysPerMonth(AYear, AMonth) > CurDay then ADay := CurDay
  else ADay := DaysPerMonth(AYear, AMonth);
  CalendarDate := EncodeDate(AYear, AMonth, ADay);
  UpdateCalendar;
end;

procedure TWqCalendar.PrevMonth;
begin
  ChangeMonth(-1);
end;

procedure TWqCalendar.NextMonth;
begin
  ChangeMonth(1);
end;

procedure TWqCalendar.NextYear;
begin
  if IsLeapYear(Year) and (Month = 2) and (Day = 29) then Day := 28;
  Year := Year + 1;
end;

procedure TWqCalendar.PrevYear;
begin
  if IsLeapYear(Year) and (Month = 2) and (Day = 29) then Day := 28;
  Year := Year - 1;
end;

procedure TWqCalendar.UpdateCalendar;
var
  AYear, AMonth, ADay: Word;
  FirstDate: TDateTime;
begin
  FUpdating := True;
  try
    DecodeDate(FDate, AYear, AMonth, ADay);
    FirstDate := EncodeDate(AYear, AMonth, 1);
    FMonthOffset := 2 - ((DayOfWeek(FirstDate) - StartOfWeek + 7) mod 7); { day of week for 1st of month }
    if FMonthOffset = 2 then FMonthOffset := -5;
    MoveColRow((ADay - FMonthOffset) mod 7, (ADay - FMonthOffset) div 7 + 1,
      False, False);
    Invalidate;
  finally
    FUpdating := False;
  end;
end;

procedure TWqCalendar.WMSize(var Message: TWMSize);
var
  GridLines: Integer;
  iTitleHeight : Integer;
begin
  GridLines := 6 * GridLineWidth;
  DefaultColWidth := (Message.Width - GridLines) div 7;
  DefaultRowHeight := (Message.Height - GridLines) div 7;
  iTitleHeight := DefaultRowHeight div 2;
  DefaultRowHeight := DefaultRowHeight + iTitleHeight mod 7 ;
  RowHeights[0] := iTitleHeight;
end;

function TWqCalendar.YearCyclical:String;
begin
  Result := GetCyclical(FDate,wqYear);
end;


function TWqCalendar.MonthCyclical:String;
begin
  Result := GetCyclical(FDate,wqMonth);
end;

function TWqCalendar.DayCyclical:String;
begin
  Result := GetCyclical(FDate,wqDay);
end;

function TWqCalendar.HourCyclical(ADate :TDateTime):String;
begin
  Result := GetCyclical(ADate,wqHour);
end;


function TWqCalendar.Animals:String;
begin
  Result := GetAnimals(NLYear);
end;

function TWqCalendar.SolarTerm:String;
begin
  Result := GetSolarTerm(FDate);
end;

function TWqCalendar.HolDay:String;
begin
  //
end;

function TWqCalendar.NLYear:Integer;
begin
  Result := CnYearOfDate(FDate);
end;

function TWqCalendar.NLMonth:Integer;
begin
  Result := CnMonthOfDate(FDate);
end;

function TWqCalendar.NLDay:Integer;
begin
  Result := CnDayOfDate(FDate);
end;


procedure Register;
begin
  RegisterComponents ('WQ Library', [TWqCalendar]);
end;

end.