mycalendar.pas

关于日期类型的应用的组件,可以很好的设置日期的

unit myCalendar;
{*******************************************************
项目名称:浦东邮件处理中心信息系统

作者: 李成军
创建日期:2004-3-10
描述: 好多日期控件不好用,于是自己写一个吧.

更新列表:
日期　   作者　　描述


TODO:
1."今天"是指本地机器时间.如果用要用远程服务器时间,需再处理.
*******************************************************}

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, Buttons, ExtCtrls;
const N=42;//
type
  TfrmCalendar = class(TForm)
    Pbake: TPanel;
    X0: TSpeedButton;
    X1: TSpeedButton;
    X2: TSpeedButton;
    X3: TSpeedButton;
    X4: TSpeedButton;
    X5: TSpeedButton;
    X6: TSpeedButton;
    sb0: TSpeedButton;
    sb1: TSpeedButton;
    sb2: TSpeedButton;
    sb3: TSpeedButton;
    sb4: TSpeedButton;
    sb5: TSpeedButton;
    sb6: TSpeedButton;
    sb7: TSpeedButton;
    sb8: TSpeedButton;
    sb9: TSpeedButton;
    sb10: TSpeedButton;
    sb11: TSpeedButton;
    sb12: TSpeedButton;
    sb13: TSpeedButton;
    sb14: TSpeedButton;
    sb15: TSpeedButton;
    sb16: TSpeedButton;
    sb17: TSpeedButton;
    sb18: TSpeedButton;
    sb19: TSpeedButton;
    sb20: TSpeedButton;
    sb21: TSpeedButton;
    sb22: TSpeedButton;
    sb23: TSpeedButton;
    sb24: TSpeedButton;
    sb25: TSpeedButton;
    sb26: TSpeedButton;
    sb27: TSpeedButton;
    sb28: TSpeedButton;
    sb29: TSpeedButton;
    sb30: TSpeedButton;
    sb31: TSpeedButton;
    sb32: TSpeedButton;
    sb33: TSpeedButton;
    sb34: TSpeedButton;
    sb35: TSpeedButton;
    sb36: TSpeedButton;
    sb37: TSpeedButton;
    sb38: TSpeedButton;
    sb39: TSpeedButton;
    sb40: TSpeedButton;
    sb41: TSpeedButton;
    BitBtn1: TBitBtn;
    BitBtn2: TBitBtn;
    BitBtn3: TBitBtn;
    Panel1: TPanel;
    SpeedButton1: TSpeedButton;
    SpeedButton2: TSpeedButton;
    cmbMonth: TComboBox;
    edtYear: TEdit;
    procedure SpeedButton2Click(Sender: TObject);
    procedure SpeedButton1Click(Sender: TObject);
    procedure cmbMonthChange(Sender: TObject);
    procedure BitBtn2Click(Sender: TObject);
    procedure BitBtn3Click(Sender: TObject);
    procedure BitBtn1Click(Sender: TObject);
    procedure edtYearChange(Sender: TObject);
    procedure edtYearKeyPress(Sender: TObject; var Key: Char);
    procedure FormShow(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);

    procedure SBclick(sender:TObject);
    procedure SBDlclick(sender:TObject);
  private
    HaveValue:Boolean;//有值!
    procedure ShowCaptionByYM(year,month:word);
  public
  end;

function GetDate(SDate:Tdatetime):Tdatetime;overload;
function GetDate():Tdatetime;overload;

var
  frmCalendar: TfrmCalendar;
  Y,M,D:word;
  OldDate:TdateTime;
  CurrDate:Tdatetime;

implementation

{$R *.dfm}
{frmCalendar}

function GetDate():Tdatetime;
begin
  Result:=GetDate(-1);
end;


function GetDate(SDate: Tdatetime):Tdatetime;
var P:TPoint;
begin
  frmCalendar:=TfrmCalendar.Create(nil);
  //确定弹出位置
  //begin
  getCursorPos(p);
  frmCalendar.Left :=p.X -frmCalendar.Width;
  if frmCalendar.Left<0 then
  frmCalendar.Left:=5;
  frmCalendar.Top :=p.Y +5;
  if frmCalendar.Top+frmCalendar.Height >Screen.Height then
  frmCalendar.Top :=p.Y -frmCalendar.Height-5;
  //end

  try
    OldDate:=SDate;
    if SDate=-1 then
      SDate:=Date;
    DecodeDate(SDate,y,m,d);
    frmCalendar.ShowModal;
    Result := CurrDate;
  finally
    frmCalendar.Free;
  end;
end;

procedure TfrmCalendar.ShowCaptionByYM(year, month: word);
var
  fromIndex:integer;
  i:integer;
  tempDate:Tdatetime;
  DayCaption:string;
begin
  edtYear.Text :=inttostr(year);
  cmbMonth.ItemIndex :=month-1;

  tempDate:=encodeDate(year,month,1);
  fromIndex:=dayofweek(tempDate);   //dayofweek's result is 1-7
  case fromIndex of
    1: fromIndex:=7;
    2..7: fromIndex:=fromIndex-1;
  end;
  //列上月日期
  for i:=fromIndex-1 downto 0 do
  begin
    tempDate:=tempDate-1;
    DayCaption:=FormatDatetime('D',tempDate);
    with TSpeedButton(FindComponent('sb' + IntToStr(i))) do
    begin
      caption:=DayCaption;
      tag:=month-1;
      Font.Color :=clGray;
    end;
  end;
  //列本月和下月日期
  tempDate:=encodeDate(year,month,1);
  for i:=fromIndex to N-1 do
  begin

    DayCaption:=FormatDatetime('D',tempDate);
    with TSpeedButton(FindComponent('sb' + IntToStr(i))) do
    begin
      caption:=DayCaption;
      //判断是当月还是下月.
      if FormatDatetime('M',tempDate)=inttostr(month) then
      begin
        tag:=month;
        Font.Color :=clBlack;
        if FormatDatetime('D',tempDate)=inttostr(D) then
        down:=true;
      end
      else
      begin
        tag:=month+1;
        Font.Color :=clGray;
      end;  
    end;

    tempDate:=tempDate+1;
  end;
end;

procedure TfrmCalendar.SpeedButton2Click(Sender: TObject);
begin
  Y:=Y+1;
  edtYear.Text :=inttostr(Y);
  ShowCaptionByYM(y,m);
end;

procedure TfrmCalendar.SpeedButton1Click(Sender: TObject);
begin
  Y:=Y-1;
  edtYear.Text :=inttostr(Y);
  ShowCaptionByYM(y,m);
end;

procedure TfrmCalendar.cmbMonthChange(Sender: TObject);
begin
  M:=cmbMonth.ItemIndex+1;
  ShowCaptionByYM(y,m); 
end;

procedure TfrmCalendar.BitBtn2Click(Sender: TObject);
begin
  CurrDate:=encodeDate(y,m,d);
  HaveValue:=true;
  modalResult:=mrOK;
end;

procedure TfrmCalendar.BitBtn3Click(Sender: TObject);
begin
  CurrDate:=-1;
  HaveValue:=true;
  modalResult:=mrOK;
end;

procedure TfrmCalendar.BitBtn1Click(Sender: TObject);
begin
  CurrDate:=Date; //todo
  HaveValue:=true;
  modalResult:=mrOK;
end;

procedure TfrmCalendar.SBclick(sender: TObject);
var
  DayCaption:string;
  SBtag:integer;
begin
  DayCaption:=TspeedButton(sender).Caption ;
  SBtag :=TspeedButton(sender).Tag ;
  D:=strtoint(DayCaption);

  if SBtag<>M then      //如果不是本月日期.则显示上月或下月的日期.
  begin
    M:=SBtag;
    if M=0 then
    begin
      Y:=Y-1;
      M:=12;
    end;
    if M=13 then
    begin
      Y:=Y+1;
      M:=1;
    end;
    ShowCaptionByYM(Y,M);
  end;
end;

procedure TfrmCalendar.edtYearChange(Sender: TObject);
begin
  if length(edtYear.Text)<>4 then
  begin
    //showMEssage('请输入有效年份!');
    exit;
  end;
  Y:=strtoint(edtYear.text);
  ShowCaptionByYM(y,m);
end;

procedure TfrmCalendar.edtYearKeyPress(Sender: TObject; var Key: Char);
begin
  inherited;
  if not (key in ['0','1','2','3','4','5','6','7','8','9',#8,#13]) then
  key:=#0;
end;

procedure TfrmCalendar.FormShow(Sender: TObject);
begin
  ShowCaptionByYM(y,m);
end;

procedure TfrmCalendar.FormClose(Sender: TObject;
  var Action: TCloseAction);
begin
  if not HaveValue then
  CurrDate:=OldDate;
end;

procedure TfrmCalendar.SBDlclick(sender: TObject);
var
  DayCaption:string;
  SBtag:integer;
begin
  DayCaption:=TspeedButton(sender).Caption ;
  SBtag :=TspeedButton(sender).Tag ;
  D:=strtoint(DayCaption);

  if SBtag<>M then      //如果不是本月日期.则显示上月或下月的日期.
  begin
    M:=SBtag;
    if M=0 then
    begin
      Y:=Y-1;
      M:=12;
    end;
    if M=13 then
    begin
      Y:=Y+1;
      M:=1;
    end;
    ShowCaptionByYM(Y,M);
  end;
  CurrDate:=encodeDate(y,m,d);
  HaveValue:=true;
  ModalResult:=mrOK;
end;

end.