datewin.pas

含阴历的中国式日历

{
***********************************************************
************* 2007-03-27 modify by simonlee ***************
*********************** QQ:48211328 ***********************
******************* Email:[e-mail] ******************
1.添加与修改界面按钮功能(年、月、前一天、今天、后一天、确定、取消);
2.修改'星期六'与'星期日'颜色显示(区分);
***********************************************************
}

unit DateWin;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls, StdCtrls, ComCtrls, DateUtils, ImgList, Buttons;

type
  TFRM_Date = class(TForm)
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    Label4: TLabel;
    Label5: TLabel;
    Label6: TLabel;
    Label7: TLabel;
    Label8: TLabel;
    day1: TLabel;
    Cnday: TLabel;
    Bevel1: TBevel;
    Bevel2: TBevel;
    Label16: TLabel;
    Shape2: TShape;
    Label20: TLabel;
    Label21: TLabel;
    Label22: TLabel;
    Image1: TImage;
    Shape1: TShape;
    RzBitBtn1: TSpeedButton;
    RzBitBtn2: TSpeedButton;
    RzBitBtn3: TSpeedButton;
    RzBitBtn4: TSpeedButton;
    lbl1: TLabel;
    lbl2: TLabel;
    RzBitBtn5: TSpeedButton;
    RzBitBtn6: TSpeedButton;
    RzBitBtn7: TSpeedButton;
    RzBitBtn8: TSpeedButton;
    RzBitBtn9: TSpeedButton;
    procedure CnDayClick(Sender: TObject);
    procedure CHnDayClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure FormDeactivate(Sender: TObject);
    procedure CnDayMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure ChnDateMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure RzBitBtn1Click(Sender: TObject);
    procedure RzBitBtn2Click(Sender: TObject);
    procedure RzBitBtn4Click(Sender: TObject);
    procedure RzBitBtn3Click(Sender: TObject);
    procedure RzBitBtn5Click(Sender: TObject);
    procedure RzBitBtn6Click(Sender: TObject);
    procedure RzBitBtn7Click(Sender: TObject);
    procedure RzBitBtn8Click(Sender: TObject);
    procedure RzBitBtn9Click(Sender: TObject);

  private
    { Private declarations }
    procedure LoadLAB;
    procedure DateChange(MyTime: TDateTime);
    procedure OK;
  public
    { Public declarations }
    FPicture_AlphaBlend: Byte;
    FPicture: TbitMap;
    NDate: Tdate;
    YearEdit, MonthEdit, DayEdit: TEdit;
    ChDateLabel: TLabel;
  end;

var
  FRM_Date: TFRM_Date;
  CnDate: array[1..37] of TLabel;
  ChnDate: array[1..37] of TLabel;
  NYear, NMonth, NDay: Word;
  MHostControl: TControl;
  days1:string;

implementation

uses DateCn, ChnCalendar;

{$R *.DFM} 

function FormExists(FORM_NAME: string): BOOLEAN;
begin
  if Application.FindComponent(FORM_NAME) = nil then
    RESULT := FALSE
  else
    RESULT := TRUE;
end;

function DayOfMonth(Year, Month: Integer): integer; overload;
begin
  try
    Result := MonthDays[IsLeapYear(Year), Month];
  except
    Result := 0;
  end;
end;

function DayOfMonth(Dates: TDateTime): integer; overload;
var
  Year, Month, Day, Hour: Word;
begin
  DecodeDate(Dates, Year, Month, day);
  Result := MonthDays[IsLeapYear(Year), Month];
end;

function DaysOfMonth(Dates: TDateTime): Integer;
begin
  Result := DayOfMonth(YearOf(Dates), MonthOf(Dates));
end;

function SetDateTime(NYear, NMonth, NDay: Word): TDate;
var
  MyDay: Word;
begin
  MyDay := DayOfMonth(NYear, NMonth);
  if MyDay < NDay then
    NDay := MyDay;
  Result := EncodeDate(NYear, NMonth, NDay);
end; 

procedure TFRM_Date.LoadLAB;
var
  i: integer;
begin
  for i := 1 to 37 do
  begin
    CnDate[i] := TLabel.Create(self);
    CnDate[i].parent := self;
    ChnDate[i] := TLabel.Create(self);
    ChnDate[i].parent := self;
    CnDate[i].OnClick := CnDayClick;
    CnDate[i].OnMouseDown := CnDayMouseDown;
    ChnDate[i].OnClick := ChnDayClick;
    ChnDate[i].OnMouseDown := ChnDateMouseDown;
    CnDate[i].AutoSize := false;
    ChnDate[i].AutoSize := false;
    CnDate[i].Width := day1.Width;
    ChnDate[i].Width := Cnday.Width;
    CnDate[i].Height := day1.Height;
    ChnDate[i].Height := Cnday.Height;
    CnDate[i].Alignment := day1.Alignment;
    ChnDate[i].Alignment := Cnday.Alignment;
    CnDate[i].Layout := day1.Layout;
    ChnDate[i].Layout := Cnday.Layout;
    if i = 1 then
     begin
      CnDate[i].Left := day1.Left;
      CnDate[i].Top := day1.Top;
      ChnDate[i].Left := Cnday.Left;
      ChnDate[i].Top := Cnday.Top;
     end
    else
     begin
      if ((i - 1) / 7) = ((i - 1) div 7) then
       begin
        CnDate[i].Top := CnDate[i - 1].Top + 32;
        CnDate[i].Left := day1.Left;
        ChnDate[i].Top := ChnDate[i - 1].Top + 32;
        ChnDate[i].Left := Cnday.Left;
       end
      else
       begin
        CnDate[i].Top := CnDate[i - 1].Top;
        CnDate[i].Left := CnDate[i - 1].Left + 42;
        ChnDate[i].Top := ChnDate[i - 1].Top;
        ChnDate[i].Left := ChnDate[i - 1].Left + 42;
       end;
     end;
    CnDate[i].Font := day1.Font;
    ChnDate[i].Font := Cnday.Font;
    CnDate[i].Font.Color := clBlack;
    CnDate[i].AutoSize := false;
    ChnDate[i].AutoSize := false;
    CnDate[i].Transparent := true;
    ChnDate[i].Transparent := true;
  end;
end;

procedure TFRM_Date.DateChange(MyTime: TDateTime);
var
  i,S:integer;
  StarNo,StarNo1:integer;
  Present,Present1:TDateTime;
  Year, Month, Day, Hour: Word;
  t1,t2:String;
begin
  Label1.Caption:=IntToStr(DateUtils.YearOf(Mytime));
  Label20.Caption:=Label1.Caption;
  i:=DateUtils.monthOf(Mytime);
  Label16.Caption:=inttostr(i);
  if i<10 then
   t1:=' '+inttostr(i)
  else
   t1:=inttostr(i);
  lbl2.Caption:=t1;
  Label21.Caption:=CnanimalOfYear(Mytime);
  for i := 1 to 37 do
  begin
    CnDate[i].Visible := false;
    ChnDate[i].Visible := false;
    ChnDate[i].Font.Color := clBlack;
    CnDate[i].Font.Color := clBlack;
    CnDate[i].Font.Size := 11;
    CnDate[i].Color := self.Color;
    ChnDate[i].Color := self.Color;
  end;
  DecodeDate(MyTime, Year, Month, Day);
  Present:=EncodeDate(Year, Month, 1);
  StarNo:=dayofweek(Present);
  s:=starno + DayOfMonth(Present) - 1;
  try
    for i := StarNo to s do
    begin
      Present := EncodeDate(Year, Month, i - StarNo + 1);
      CnDate[i].Caption:=IntToStr(i-StarNo+1); // 日期
      t2:=Label1.Caption+'-'+lbl2.Caption+cndate[i].Caption;
      Present1:=EncodeDate(Year,Month,i-StarNo+1);
      StarNo1:=dayofweek(Present1);
      if StarNo1=1 then // 星期日
       cndate[i].Font.Color:=clRed //clMaroon
      else
      if StarNo1=7 then // 星期六
       cndate[i].Font.Color:=clPurple;

      CnDate[i].Tag := i - StarNo + 1;
      ChnDate[i].Tag := CnDate[i].Tag;
      ChnDate[i].Caption := CnDayOfDate(Present); // 农历
      if ChnDate[i].Caption = '初一' then
      begin
        ChnDate[i].Caption := CnMonthOfDate(Present);
        ChnDate[i].Font.Color := clRed;
      end
      else
        ChnDate[i].Font.Color := Cnday.Font.Color;
      if length(Holiday(MyTime, i - StarNo + 1)) > 3 then
       begin
        ChnDate[i].Caption := Holiday(MyTime, i - StarNo + 1);
        ChnDate[i].Font.Color := $000080FF;
        chndate[i].Hint:=
         '公历:'+Label1.Caption+'年'+lbl2.Caption+'月'+cndate[i].Caption+'日'+#13+#10+//'日(今年第'+inttostr(DaysNumberOfDate(MyTime))+'天)'+#13+#10+
         '农历:'+CnSkyStemOfYear(MyTime)+'   '+CnDateOfDateStr(Present)+#13+#10+
         '节日:'+Holiday_allname(MyTime,i-StarNo+1)
       end
      else
       begin
        chndate[i].Hint:=
         '公历:'+Label1.Caption+'年'+lbl2.Caption+'月'+cndate[i].Caption+'日'+#13+#10+//'日(今年第'+inttostr(DaysNumberOfDate(MyTime))+'天)'+#13+#10+
         '农历:'+CnSkyStemOfYear(MyTime)+'   '+CnDateOfDateStr(Present);
       end;
      if DateCn.GetLunarHolDay(Present)<>'' then
      begin
        ChnDate[i].Caption := GetLunarHolDay(Present);
        ChnDate[i].Font.Color := $00FF5353;
      end;
      if DateCn.CnDayOfDateJr(Present) <> '' then
      begin
        ChnDate[i].Caption := CnDayOfDateJr(Present);
        ChnDate[i].Font.Color := $000080FF;
      end;
      if i - StarNo + 1 = day then
      begin
        Shape2.Left := CnDate[i].left - 1;
        Shape2.Top := CnDate[i].top + 1;
        Label22.Caption := Constellation(Present, day);
      end;
      CnDate[i].Visible := true;
      ChnDate[i].Visible := true;
    end;
  except
    on EConvertError do
    begin
     exit;
    end
  else exit;
  end;
end;

procedure TFRM_Date.FormCreate(Sender: TObject);
begin
  LoadLAB;
  NDate:=Date(); 
end;

procedure TFRM_Date.FormShow(Sender: TObject);
begin
  DecodeDate(NDate, NYear, NMonth, NDay);
  DateChange(NDate);
  days1:=FormatDateTime('dd',NDate);
//  showmessage(DateTimeToStr(ndate)+#13+#13+days1);
end;

procedure TFRM_Date.CHnDayClick(Sender: TObject);
begin
//  Label5Click(nil);
  Nday := (sender as TLabel).Tag;
  OK;
end;

procedure TFRM_Date.CnDayClick(Sender: TObject);
begin
  Nday := (sender as TLabel).Tag;
  OK;
end;

procedure TFRM_Date.FormDeactivate(Sender: TObject);
begin
 Self.Close;
end;

procedure TFRM_Date.ChnDateMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  Shape2.Left := (sender as TLabel).left;
  Shape2.Top := (sender as TLabel).top - 16;
end;

procedure TFRM_Date.CnDayMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  Shape2.Left := (sender as TLabel).left - 1;
  Shape2.Top := (sender as TLabel).top + 1;
end;

procedure TFRM_Date.OK;
begin
  NDate:=EncodeDate(NYear, NMonth, NDay);
  TChnCalendar(MHostControl).DateTime := NDate;
  Close;
end;

procedure TFRM_Date.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  Application.RemoveComponent(Self);
  Self:=nil;
  Self.Free;
end;

procedure TFRM_Date.RzBitBtn1Click(Sender: TObject); // 上一年
var
 s1,s2,s3:string;
 i,j:integer;
 Present:TDate;
begin
 s1:=trim(Label1.Caption);
 i:=strtoint(s1);
 if i<=1111 then
  i:=1111
 else
  i:=i-1;
 Label1.Caption:=inttostr(i);
 Label20.Caption:=Label1.Caption;

 NYear:=i;
 Present:=SetDateTime(NYear,NMonth,NDay);
 DateChange(Present);
end;

procedure TFRM_Date.RzBitBtn2Click(Sender: TObject); // 上一月
var
 s1,s2,s3:string;
 i,j:integer;
 Present:TDate;
begin
 s1:=trim(lbl2.Caption);
 s3:=trim(label1.caption);
 i:=strtoint(s1);
 if i<=1 then
  begin
   i:=12;
   label1.caption:=inttostr(strtoint(s3)-1);
  end
 else
  i:=i-1;
 if i<10 then
  s2:={'0'+}inttostr(i)
 else
  s2:=inttostr(i);
 lbl2.Caption:=s2;
 label20.Caption:=Label1.Caption;
 label16.Caption:=inttostr(i);

 nyear:=StrToInt(Label1.Caption);
 NMonth:=i;
 Present:=SetDateTime(NYear,NMonth,NDay);
 DateChange(Present);
end;

procedure TFRM_Date.RzBitBtn3Click(Sender: TObject); // 下一月
var
 s1,s2,s3:string;
 i,j:integer;
 Present:TDate; 
begin
 s1:=trim(lbl2.Caption);
 s3:=trim(Label1.Caption);
 i:=strtoint(s1);
 if i>=12 then
  begin
   i:=1;
   Label1.Caption:=IntToStr(strtoint(s3)+1);
  end
 else
  i:=i+1;
 if i<10 then
  s2:={'0'+}inttostr(i)
 else
  s2:=inttostr(i);
 lbl2.Caption:=s2;
 label20.Caption:=Label1.Caption;
 label16.Caption:=inttostr(i);

 nyear:=StrToInt(Label1.Caption);
 NMonth:=i;
 Present:=SetDateTime(NYear,NMonth,NDay);
 DateChange(Present);
end;

procedure TFRM_Date.RzBitBtn4Click(Sender: TObject); // 下一年
var
 s1,s2,s3:string;
 i,j:integer;
 Present:TDate;
begin
 s1:=trim(Label1.Caption);
 i:=strtoint(s1);
 if i>2999 then
  i:=2999
 else
  i:=i+1;
 Label1.Caption:=inttostr(i);
 label20.Caption:=Label1.Caption;

 NYear:=i;
 Present:=SetDateTime(NYear,NMonth,NDay);
 DateChange(Present);
end;

procedure TFRM_Date.RzBitBtn5Click(Sender: TObject); // 今天
begin
 NDate:=date();
 FormShow(nil);
end;

procedure TFRM_Date.RzBitBtn6Click(Sender: TObject); // 前一天
var
 s1,s2,s3:string;
 p1:Tdate;
begin
 days1:=days1;
 s1:=Label1.Caption+'-'+lbl2.Caption+'-'+days1;
 p1:=StrToDateTime(s1)-1;
 days1:=FormatDateTime('dd',p1);
 nday:=StrToInt(days1);
 NDate:=p1;
 FormShow(nil);
end;

procedure TFRM_Date.RzBitBtn7Click(Sender: TObject); // 后一天
var
 s1,s2,s3:string;
 p1:Tdate;
begin
 days1:=days1;
 s1:=Label1.Caption+'-'+lbl2.Caption+'-'+days1;
 p1:=StrToDateTime(s1)+1;
 days1:=FormatDateTime('dd',p1);
 nday:=StrToInt(days1);
 NDate:=p1;
 FormShow(nil);
end;

procedure TFRM_Date.RzBitBtn8Click(Sender: TObject); // 确定
begin
  NDate:=EncodeDate(NYear, NMonth, NDay);
  TChnCalendar(MHostControl).DateTime := NDate;
  Close;
end;

procedure TFRM_Date.RzBitBtn9Click(Sender: TObject); // 取消
begin
 Close;
end;

end.