chncalendar.pas

具有农历功能的Delphi Builder日历控件

{************************************************}
{ xzhifei - [e-mail]                      }
{ 2006.5.2                                       }
{************************************************}
unit ChnCalendar;

interface

uses
  Windows, DateUtils, Messages, DateWin, Forms, SysUtils, DateCn, StdCtrls, Classes, Controls, CommCtrl, ComCtrls, Graphics;

type
  tagRGBTRIPLE = packed record
    rgbtBlue: Byte;
    rgbtGreen: Byte;
    rgbtRed: Byte;
  end;
  TRGBTriple = tagRGBTRIPLE;
  PRGBTripleArray = ^TRGBTripleArray;
  TRGBTripleArray = array[0..32767] of TRGBTriple;
  TChnCalendar = class(TCustomControl)
  private
    { Private declarations }
//    isChangeBmp: Boolean;
    CnDate: string;
    ButtonRect: TRect;
    YearEdit,
      MonthEdit,
      DayEdit: TEdit;
    MouseStyle: integer;
    FLastChange: TSystemTime;
    FDateTime: TDateTime;
    FFrameColor: TColor;
    FCnDateColor: TColor;
    FButtonColor: TColor;
    FBackPicture: TbitMap;
    FAlphaBlend: Byte;
    procedure DrawButton(iStyle: integer);
    procedure SetDateTime(const Value: TDateTime);
    procedure WMSize(var Msg: TWMSize); message wm_Size;
    procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
    procedure SetFrameColor(const Value: TColor);
    procedure setCnDateColor(const Value: TColor);
    procedure setButtonColor(const Value: TColor);
    procedure SetBackPicture(const Value: TbitMap);
    procedure WMLButtonUp(var Message: TWMLButtonUp); message WM_LBUTTONUP;
//    procedure WMMouseMove(var Message: TWMMouseMove); message WM_MOUSEMOVE;
    procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
    procedure CMCtl3DChanged(var Message: TMessage); message CM_CTL3DCHANGED;
  protected
    { Protected declarations }
    procedure Paint; override;
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    { Published declarations }
    property DateTime: TDateTime read FDateTime write SetDateTime;
    property FrameColor: TColor read FFrameColor write SetFrameColor;
    property CnDateColor: TColor read FCnDateColor write setCnDateColor;
    property ButtonColor: TColor read FButtonColor write setButtonColor;
    property BackPicture: TbitMap read FBackPicture write SetBackPicture;
    property AlphaBlend: Byte read FAlphaBlend write FAlphaBlend;
    property Color;
    property Align;
    property Anchors;
    property Enabled;
    property Font;
    property ParentBiDiMode;
    property ParentBackground;
    property ParentColor;
    property ParentCtl3D;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property Visible;
    property OnClick;
    property OnDblClick;
    property OnEnter;
    property OnExit;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnResize;
    property Ctl3D;
  end;

procedure Register;

implementation

uses Grids;

procedure Register;
begin
  RegisterComponents('Standard', [TChnCalendar]);
end;



{ TChnCalendar }

procedure BmpAlphaBlend(var dBmp: TBitMap; sBmp: TBitmap; Pos: TPoint; Alpha: integer; TranColor: TColor = -1);
  function IntToByte(i: Integer): Byte;
  begin
    if i > 255 then
      Result := 255
    else if i < 0 then
      Result := 0
    else
      Result := i;
  end;
  function GetSLColor(pRGB: TRGBTriple): TColor;
  begin
    Result := RGB(pRGB.rgbtRed, pRGB.rgbtGreen, pRGB.rgbtBlue);
  end;
var
  p0, p1: PRGBTripleArray;
  r, g, b, p, x, y: Integer;
begin
  sBmp.PixelFormat := pf24bit;
  dBmp.PixelFormat := pf24bit;
  if TranColor = -1 then
    TranColor := sBmp.Canvas.Pixels[0, 0];
  for y := 0 to sBmp.Height - 1 do
    if (y + Pos.y >= 0) and (y + Pos.Y < dBmp.Height) then
    begin
      p0 := dBmp.ScanLine[y + Pos.y];
      p1 := sBmp.ScanLine[y];
      for x := 0 to sBmp.Width - 1 do
        if (x + pos.X >= 0) and (x + Pos.X < dBmp.Width) then
          if GetSLCOlor(p1[x]) <> TranColor then
          begin
            p0[x + pos.X].rgbtRed := IntToByte((p0[x + pos.X].rgbtRed * (100 - Alpha) +
              p1[x].rgbtRed * Alpha) div 100);

            p0[x + pos.X].rgbtGreen := IntToByte((p0[x + pos.X].rgbtGreen * (100 - Alpha) +
              p1[x].rgbtGreen * Alpha) div 100);

            p0[x + pos.X].rgbtBlue := IntToByte((p0[x + pos.X].rgbtBlue * (100 - Alpha) +
              p1[x].rgbtBlue * Alpha) div 100);
          end;
    end;

end;


constructor TChnCalendar.Create(AOwner: TComponent);
var
  P: TPoint;
  bmp: TbitMap;
begin
//  CheckCommonControl(ICC_USEREX_CLASSES);
  inherited Create(AOwner);
//  DateTimeToSystemTime(DateTime, FLastChange);
//  FShowCheckbox := False;
//  FChecked := True;
  SetBounds(0, 0, 186, 21);
  Ctl3D := True;
  ControlStyle := ControlStyle + [csAcceptsControls];
  FBackPicture := TBitMap.Create;
  Color := clWindow;
  FCnDateColor := clGreen;
  FButtonColor := clPurple;
  FAlphaBlend := 50;
  ParentColor := False;
  TabStop := True;
  YearEdit := TEdit.Create(Self);
  with YearEdit do
  begin
    BorderStyle := bsNone;
    Parent := Self;
    SetBounds(0, 0, 31, 13);
    Left := 3;
    Top := 1;
    Text := FormatDateTime('YYYY', Now);
  end;

  MonthEdit := TEdit.Create(Self);
  with MonthEdit do
  begin
    BorderStyle := bsNone;
    Parent := Self;
    SetBounds(0, 0, 15, 13);
    Left := 41;
    Top := 1;
    Text := FormatDateTime('M', Now);
  end;

  DayEdit := TEdit.Create(Self);
  with DayEdit do
  begin
    BorderStyle := bsNone;
    Parent := Self;
    SetBounds(0, 0, 15, 13);
    Left := 65;
    Top := 1;
    Text := FormatDateTime('D', Now);
  end;

  FRM_Date := TFRM_Date.Create(Application);
  with FRM_Date do
  begin
    Image1.Picture.Bitmap.Assign(FBackPicture);
    Label16.Visible := FBackPicture.Width = 0;
    Label20.Visible := FBackPicture.Width = 0;
    if Image1.Picture.Graphic <> nil then
    begin
      bmp := TbitMap.Create;
      bmp.Width := Image1.Width;
      bmp.Height := Image1.Height;
      bmp.Canvas.Brush.Color := Color;
      bmp.Canvas.FillRect(RECT(0, 0, bmp.Width,
        bmp.Height));

      P := Point((bmp.Width - FBackPicture.Width) div 2,
        (bmp.Height - FBackPicture.Height) div 2);
      BmpAlphaBlend(bmp, FBackPicture, P, FAlphaBlend);
      Image1.Canvas.Draw(0, 0, bmp);
      bmp.free;

    end;
  end;

  DateTime := Now;
//  CnDate := CnanimalOfYear(DateTime) + CnMonthOfDate(DateTime) + CnDayOfDate(DateTime);

end;


destructor TChnCalendar.Destroy;
begin
  FBackPicture.Free;
  inherited;
end;


procedure DrawClt3DButton(aCanvas: TCanvas; R: TRect; IsDown: Boolean);
begin
  with aCanvas do
  begin
    Brush.Color := clBtnFace;
    FillRect(R);
    FrameRect(R);
    if IsDown then
    begin
      Brush.Color := clBtnShadow  ;
      Pen.Color := clBtnShadow;
      FrameRect(R);
    end
    else
    begin
      Brush.Color := clBlack;
      Pen.Color := clBlack;
      MoveTo(r.Right - 1, r.Top);
      LineTo(r.Right - 1, r.Bottom);
      MoveTo(r.Left, r.Bottom - 1);
      LineTo(r.Right, r.Bottom - 1);

      InflateRect(R, -1, -1);
      Brush.Color := clBtnShadow;
      Pen.Color := clBtnShadow;
      FrameRect(R);

      Brush.Color := clBtnHighlight  ;
      Pen.Color := clBtnHighlight;
      MoveTo(r.Left, r.Top);
      LineTo(r.Right - 1, r.Top);
      MoveTo(r.Left, r.Top);
      LineTo(r.Left, r.Bottom - 1);
    end;
  end;
end;

procedure TChnCalendar.DrawButton(iStyle: integer);
  procedure Trigon(Canvas: TCanvas; xy1, xy2, xy3: TPoint);
  var
    xy: array[1..4] of TPoint;
  begin
    xy[1] := xy1;
    xy[2] := xy2;
    xy[3] := xy3;
    xy[4] := xy1;
    Canvas.Polygon(xy);
  end;
var
  TrigonLeft, TrigonTop: integer;
  R: TRect;
begin
  Canvas.Brush.Style := bsSolid;
  case iStyle of
    0:
      begin
        Canvas.Pen.Color := FrameColor;
        Canvas.Brush.Color := FButtonColor; // clPurple;
      end;
    1, 2:
      begin
        Canvas.Pen.Color := clBlack;
        Canvas.Brush.Color := $00E47AC8;
      end;
  end;
  if Ctl3D then
  begin
    R := RECT(Width - 20, 3, Width - 2, Height - 2);
    DrawClt3DButton(Canvas, R, iStyle = 1);
  end
  else
  begin
    R := RECT(Width - 15, 3, Width - 2, Height - 2);
    Canvas.Rectangle(R);
  end;
  //画三角形
  TrigonLeft := r.Left + ((r.Right - r.Left) - 6) div 2;
  TrigonTop := r.Top + ((r.Bottom - r.Top) - 3) div 2;
  if Ctl3D then
  begin
    Canvas.Brush.Color := clBtnText;
    Canvas.Pen.Color := clBtnText;
  end
  else
  begin
    case iStyle of
      0, 2:
        begin
          Canvas.Brush.Color := clWhite;
          Canvas.Pen.Color := clWhite;
        end;
      1:
        begin
          Canvas.Brush.Color := $00E4E4E4;
          Canvas.Pen.Color := $00E4E4E4;
        end;
    end;
  end;
  if iStyle = 1 then
  begin
    TrigonLeft := TrigonLeft + 1;
    TrigonTop := TrigonTop + 1;
  end;