unitmain.pas

Delphi写的小型桌面日历不错的！

unit UnitMain;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ActnList, XPStyleActnCtrls, ActnMan, ToolWin, ActnCtrls,
  ActnMenus, ExtCtrls, Grids, DateUtils,Calendar, StdCtrls, Buttons,
  RzPanel, RzButton, ImgList, RzTray, ComCtrls, Menus, DB, ADODB;

type
  TForm1 = class(TForm)
    Image1: TImage;
    ActionManager1: TActionManager;
    actFontSelect: TAction;
    actPreDay: TAction;
    actNextDay: TAction;
    FontDialog1: TFontDialog;
    actRefresh: TAction;
    ImageList1: TImageList;
    actExit: TAction;
    RzTrayIcon1: TRzTrayIcon;
    toolBar: TRzToolbar;
    BtnFont: TRzToolButton;
    BtnSkipBackward: TRzToolButton;
    BtnMoveLeft: TRzToolButton;
    BtnMoveRight: TRzToolButton;
    BtnSkipForward: TRzToolButton;
    BtnExit: TRzToolButton;
    RzSpacer1: TRzSpacer;
    BtnReminder: TRzToolButton;
    BtnNote: TRzToolButton;
    BtnSendEMail: TRzToolButton;
    BtnUtilities: TRzToolButton;
    BtnHelp: TRzToolButton;
    RzSpacer2: TRzSpacer;
    RzSpacer3: TRzSpacer;
    RzSpacer4: TRzSpacer;
    BtnRefresh: TRzToolButton;
    PopupMenu1: TPopupMenu;
    N1: TMenuItem;
    N2: TMenuItem;
    N3: TMenuItem;
    cmPreMonth: TMenuItem;
    cmNextMonth: TMenuItem;
    PopupMenu2: TPopupMenu;
    Show1: TMenuItem;
    Works1: TMenuItem;
    AddWork1: TMenuItem;
    N4: TMenuItem;
    Options1: TMenuItem;
    Exit1: TMenuItem;
    Memo1: TMemo;
    ADOConn: TADOConnection;
    tb_client: TADOTable;
    procedure actFontSelectExecute(Sender: TObject);
    procedure actRefreshExecute(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure actPreDayExecute(Sender: TObject);
    procedure actNextDayExecute(Sender: TObject);
    procedure actExitExecute(Sender: TObject);
    procedure RzTrayIcon1MinimizeApp(Sender: TObject);
    procedure Image1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure Show1Click(Sender: TObject);
    procedure Exit1Click(Sender: TObject);
    procedure AddWork1Click(Sender: TObject);
    procedure FormActivate(Sender: TObject);
    procedure FormHide(Sender: TObject);
    procedure FormDeactivate(Sender: TObject);
  private
    { Private declarations }
    Y,M,D,W     :Word;
    {the yyyy-mm-dd caption position}
    captionx,captiony:integer;
    {the calendar start position}
    calX,calY  :integer;
    {varity colors}
    cl1,clToday,clNormal:TColor;
    clCaption:TColor;
    function  GetCaptionRect:TRect;
    function  GetCalDayRect(day:Word):TRect;
    function  PointInRect(p:TPoint;r:TRect):Boolean;overload;
    function  PointInRect(x,y:integer;r:TRect):Boolean;overload;
    function  GetDayAtXY(x,y:integer):Word;
    procedure WMNCHitTest(var Msg: TWMNCHitTest);Message WM_NCHITTEST;
    //procedure WMSizeInfo(var Msg : TWMSize);Message WM_SIZE;

    {Here are some works which is to be done each day}
    procedure DoDayWork(day:TDate);
    procedure WndProc(var Message: TMessage); override;
  public
    { Public declarations }
    bPath     :Boolean;
    curSelDay :Word;
    curSelDate:TDateTime;
    procedure DrawCal;
  end;

var
  Form1: TForm1;

implementation

uses  UAlarm;

{$R *.dfm}

procedure TForm1.actFontSelectExecute(Sender: TObject);
begin
  if FontDialog1.Execute then
  begin
    image1.Canvas.Font:=FontDialog1.Font;
    clNormal:=image1.Canvas.Font.Color;
    DrawCal;
  end;
end;

procedure TForm1.DrawCal;
var
  curDay:TDateTime;
  endDay:Word;
  cy:integer;
  rect:TRect;
begin
  with image1 do
  begin
    D:=1;
    cy:=calY;
    Canvas.Brush.Color:=clWhite;
    Canvas.FillRect(ClientRect);
    curDay:=EncodeDate(Y,M,D);
    EndDay:=DayOf(EndOfAMonth(Y,M));
    image1.Canvas.Font.Color:=clCaption;
    image1.Canvas.TextOut(captionx,captiony,IntToStr(Y)+'年'+IntToSTr(M)+'月');
    while D<=EndDay do
    begin
      W:=DayOfTheWeek(curDay);
      if W in [6,7] then
        Canvas.Font.Color:=cl1
      else
        Canvas.Font.Color:=clNormal;
      if curDay=Date then
      begin
        Canvas.Font.Color:=clToday;
        Canvas.Font.Style:=[fsBold];
      end;
      //Canvas.TextOut(cx,cy,IntToStr(D));
      rect:=GetCalDayRect(d);
      canvas.TextOut(rect.left,rect.Top,IntToStr(D));
      Canvas.Font.Style:=[];

      if W=7 then
      begin
        cy:=cy+image1.Canvas.TextHeight('1')+20;
      end;
      //Inc Day
      curDay:=IncDay(curDay);
      Inc(D);
    end;
  end;
end;

procedure TForm1.actRefreshExecute(Sender: TObject);
begin
  DrawCal;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  cl1:=clRed;
  clNormal:=clBlack;
  clToday:=clGreen;
  clCaption:=clblack;
  DecodeDate(Date,Y,M,D);
  {form position}
  left:=screen.Width-width;
  top:=50;
  {caption position}
  captionx:=20;captiony:=20;
  {calendar position}
  calX:=20;calY:=40;
  DrawCal;

  with tb_client do
  begin
    close;
    tableName:='tbl_alarm';
    filter:='startTime>#'+formatDateTime('yyyy-mm-dd',now)+'#';
    filtered:=true;
    open;
    while not eof do
    begin
      memo1.Lines.Add(
        formatDatetime('yyyy-mm-dd',fieldValues['startTime'])+
        '    '+fieldByname('title').AsString);
      Next;
    end;
    close;
  end;
end;

procedure TForm1.actPreDayExecute(Sender: TObject);
var curD:TDate;
begin
  curD:=EnCodeDate(Y,M,1);
  curD:=IncMonth(curD,-1);
  DecodeDate(curD,Y,M,D);
  DrawCal;
end;

procedure TForm1.actNextDayExecute(Sender: TObject);
var curD:TDate;
begin
  curD:=EnCodeDate(Y,M,1);
  curD:=IncMonth(curD,1);
  DecodeDate(curD,Y,M,D);
  DrawCal;
end;

procedure TForm1.actExitExecute(Sender: TObject);
begin
  close;
end;

procedure TForm1.RzTrayIcon1MinimizeApp(Sender: TObject);
begin
  windowState:=wsNormal;
end;

procedure TForm1.WMNCHitTest(var Msg: TWMNCHitTest);
var flag:Boolean;
    r   :TRect;
begin
  inherited;
  r   :=GetCaptionRect;
  flag:=PointInRect(Msg.Pos.x-left,msg.Pos.y-top,r);
  {this are debugging codes
  if flag then
    showMessage(format('pos.x:%d,pos.y:%d;'#13'r.left:%d,r.top%d,r.bottom:%d,r.right:%d',
                [Msg.Pos.x,Msg.Pos.y,r.Left,r.Top,r.Bottom,r.Right])); }
  if ((Msg.Result = htTransparent) or (Msg.Result = htClient)) and flag then
    Msg.Result := htCaption;
end;

function TForm1.GetCaptionRect:TRect;
begin
  result.Left:=captionx;
  result.Top:=captiony+image1.Top;
  result.Right:=captionx+image1.Canvas.TextWidth('W')*10;
  result.Bottom:=captiony+image1.Canvas.TextHeight('P')+image1.Top;
end;

function TForm1.GetCalDayRect(day:Word):TRect;
var
  WeekOfFirstDay:Word;
  GridX,GridY   :integer;
  FirstDay      :TDate;
begin
  FirstDay  :=(EncodeDate(Y,M,1));
  with Result do
  begin
    left:=0;right:=0;bottom:=0;top:=0;
  end;
  if (day<1) or (day>daysInMonth(FirstDay)) then
    exit;
  WeekOfFirstDay:=DayOfTheWeek(firstDay);
  //GridX:=(day -WeekOfFirstDay+8) mod 7 ;
  GridX:=DayOfTheWeek(EncodeDate(y,m,day))  mod 7;
  //GridY:=WeekOfTheMonth(EncodeDate(y,m,day));
  GridY:=(day-1+WeekOfFirstDay) div 7 ;
  Result.Left:=calX+image1.Canvas.TextWidth('W')*3*gridX;
  Result.Top:=calY+(image1.Canvas.TextHeight('1')+20)*gridY+image1.Top;
  result.Right:=result.Left+image1.Canvas.TextWidth('W')*2;
  result.Bottom:=result.top+image1.Canvas.TextHeight('1');
end;

function TForm1.PointInRect(p:TPoint;r:TRect):Boolean;
begin
  result:=PointInRect(p.x,p.Y,r);
end;

function TForm1.PointInRect(x,y:integer;r:TRect):Boolean;
begin
  if (x>=r.Left) and (x<=r.Right)
      and (y>=r.Top) and (y<=r.Bottom) then
    result:=true
  else
    result:=false;
end;

function Tform1.GetDayAtXY(x,y:integer):Word;
var i:integer;
begin
  result:=0;
  for i:=1 to DaysInMonth(EnCodeDate(y,m,1)) do
    if PointInRect(x,y,GetCalDayRect(i)) then
      result:=i;
end;

procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  curSelDay:=GetDayAtXY(x,y);
  if curSelDay>0 then
    curSeldate:=EncodeDate(y,m,curSelDay);
end;

{This is the work to do}
procedure TForm1.DoDayWork(day:TDate);
begin

end;

{The following is some menu operations}
procedure TForm1.Show1Click(Sender: TObject);
begin
  application.Restore;
end;

procedure TForm1.Exit1Click(Sender: TObject);
begin
  Close;
end;

procedure TForm1.AddWork1Click(Sender: TObject);
var form:TFAlarm;
begin
  {Add a new alarm}
  tb_client.Close;
  tb_client.TableName:='tbl_alarm';
  form:=TFAlarm.Create(self);
  if curSelDay>0 then
    form.SetStartTime(curSelDate);
  form.ShowModal;
  form.Free;
end;

procedure TForm1.FormActivate(Sender: TObject);
begin
  ShowWindow(Application.Handle,SW_Hide);
end;

procedure TForm1.FormHide(Sender: TObject);
begin
  showMessage('hide!');
end;

procedure TForm1.FormDeactivate(Sender: TObject);
begin
  showMessage('Deactive!');
end;

{procedure TForm1.WMSizeInfo(var Msg: TWMSize);
begin
  //SizeType: Longint;
  //   SIZE_MAXIMIZED, SIZE_MINIMIZED, SIZE_RESTORED,
  //   SIZE_MAXHIDE, SIZE_MAXSHOW
  case Msg.SizeType of
  SIZE_MAXIMIZED :
    showMessage('MAXIMIZED!');
  SIZE_MINIMIZED :
    showMessage('MINIMIZED!');
  SIZE_RESTORED :
    showMessage('RESTORED!');
  SIZE_MAXHIDE :
    showMessage('MAXHIDE!');
  SIZE_MAXSHOW :
    showMessage('MAXSHOW!');
  end;
end;  }

procedure TForm1.WndProc(var Message: TMessage);
begin
  inherited;
  
end;

end.