adatectl.pas

来自「delphi编程控件」· PAS 代码 · 共 1,516 行 · 第 1/3 页

unit adatectl;
(*
 COPYRIGHT (c) RSD Software 1997 - 98
 All Rights Reserved.
*)

{$I aclver.inc}

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Mask, Buttons, aclconst;

type
  TDayOfWeek = 0..6;

  TCustomAutoDateControl = class(TCustomControl)
  private
    ColWidth: Integer;
    FBeginDate, FEndDate: TDateTime;
    FDate: TDateTime;
    FSelectPeriod: Boolean;
    FStartOfWeek: TDayOfWeek;
    FTopRow: Integer;
    HintWindow: TWinControl;
    RowHeight: Integer;
    FOnDateChange: TNotifyEvent;
    FOnBeginDateChange: TNotifyEvent;
    FOnEndDateChange: TNotifyEvent;
    FOnHide: TNotifyEvent;

    function GetBeginDate: TDateTime;
    function GetEndDate: TDateTime;
    function GetVisibleRowCount: Integer;
    function GetWidth: Integer;
    procedure SetBeginDate(Value: TDateTime);
    procedure SetDate(Value: TDateTime);
    procedure SetEndDate(Value: TDateTime);
    procedure SetSelectPeriod(Value: Boolean);
    procedure SetStartOfWeek(Value: TDayOfWeek);
    procedure SetTopRow(Value: Integer);
    
    procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
    procedure WMActivate(var Message: TWMActivate); message WM_ACTIVATE;
    procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
    procedure WMGetDlgCode(var Message: TWMGetDlgCode); message WM_GETDLGCODE;
    procedure WMMouseActivate(var Message: TWMMouseActivate);
      message WM_MOUSEACTIVATE;
    procedure WMNCCalcSize(var Message: TWMNCCalcSize); message WM_NCCALCSIZE;
    procedure WMNCPaint(var Message: TWMNCPaint); message WM_NCPAINT;
    procedure WMSize(var Message: TWMSize); message WM_SIZE;
    procedure WMVScroll(var Message: TWMVScroll); message WM_VSCROLL;
  protected
    function ColOfDate(ADate: TDateTime): Integer;
    procedure CreateParams(var Params: TCreateParams); override;
    procedure DoDateChange; dynamic;
    procedure DoBeginDateChange; dynamic;
    procedure DoEndDateChange; dynamic;        
    function DateAtPos(const Pos: TPoint; var Found: Boolean): TDateTime;
    function FirstWeekDays(AYear, AMonth: Integer): Integer;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    function LastWeekDays(AYear, AMonth: Integer): Integer;
    function MonthAtRow(ARow: Integer): TDateTime;
    function MonthHeight(AYear, AMonth: Integer; Full: Boolean): Integer;
    function MonthTop(AYear, AMonth: Integer): Integer;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure Paint; override;
    function PosOfDate(ADate: TDateTime): TPoint;
    function RowOfDate(ADate: TDateTime): Integer;
    procedure SetParent(AParent: TWinControl); override;
    procedure SetSize;
    { Value of TopRow is zerobased. If it equals to zero than first line
      in control corresponds to beginning of Date's month. }
    property TopRow: Integer read FTopRow write SetTopRow;
    property VisibleRowCount: Integer read GetVisibleRowCount;
  public
    IsPopup: Boolean;
    constructor Create(AOwner: TComponent); override;
    procedure Hide;
    procedure Show;
    procedure ShowDate(ADate: TDateTime);
    property BeginDate: TDateTime read GetBeginDate write SetBeginDate;
    property Date: TDateTime read FDate write SetDate;
    property EndDate: TDateTime read GetEndDate write SetEndDate;
    property SelectPeriod: Boolean read FSelectPeriod write SetSelectPeriod
      default False;
    property StartOfWeek: TDayOfWeek read FStartOfWeek write SetStartOfWeek default 0;
    property OnDateChange: TNotifyEvent read FOnDateChange write FOnDateChange;
    property OnBeginDateChange: TNotifyEvent read FOnBeginDateChange write FOnBeginDateChange;
    property OnEndDateChange: TNotifyEvent read FOnEndDateChange write FOnEndDateChange;
    property OnHide: TNotifyEvent read FOnHide write FOnHide;
  end;

  TAutoDateControl = class(TCustomAutoDateControl)
  published
    { Property SelectPeriod must be first. }
    property SelectPeriod;
    property Align;
    property BeginDate;
    property Date;
    property DragCursor;
    property DragMode;
    property Enabled;
    property EndDate;
    property Font;
  {$IFDEF DELPHI3_0}
    property ImeMode;
    property ImeName;
  {$ENDIF}
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property StartOfWeek;
    property TabOrder;
    property TabStop;
    property Visible;
    property OnDateChange;
    property OnBeginDateChange;
    property OnEndDateChange;
    property OnClick;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnHide;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnStartDrag;
  end;

{$IFNDEF AOB_PS}

  TEditingPlace = (epError, epDay, epMonth, epYear);

  TCustomAutoDateEdit = class(TCustomMaskEdit)
  private
    DropDownButton: TSpeedButton;
    FDropDownHeight: Integer;
    FSelectPeriod: Boolean;
    FOnDateChange: TNotifyEvent;
    FOnBeginDateChange: TNotifyEvent;
    FOnEndDateChange: TNotifyEvent;        

    function GetBeginDate: TDateTime;
    function GetDate: TDateTime;
    function GetEndDate: TDateTime;
    procedure SetBeginDate(Value: TDateTime);
    procedure SetDate(Value: TDateTime);
    procedure SetEndDate(Value: TDateTime);
    procedure SetSelectPeriod(Value: Boolean);
    procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
  protected
    function BeginDateStr: string;
    function EndDateStr: string;
    procedure CreateParams(var Params: TCreateParams); override;
    procedure DoDateChange; dynamic;
    procedure DoBeginDateChange; dynamic;
    procedure DoEndDateChange; dynamic;        
    function EditingPlace(var EndDateEditing: Boolean): TEditingPlace;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;

    property OnDateChange: TNotifyEvent read FOnDateChange write FOnDateChange;
    property OnBeginDateChange: TNotifyEvent read FOnBeginDateChange write FOnBeginDateChange;
    property OnEndDateChange: TNotifyEvent read FOnEndDateChange write FOnEndDateChange;
  public
    constructor Create(AOwner: TComponent); override;
    procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
    property BeginDate: TDateTime read GetBeginDate write SetBeginDate;
    property Date: TDateTime read GetDate write SetDate;
    property DropDownHeight: Integer read FDropDownHeight write FDropDownHeight;
    property EndDate: TDateTime read GetEndDate write SetEndDate;
    property SelectPeriod: Boolean read FSelectPeriod write SetSelectPeriod
      default False;
  end;

  TAutoDateEdit = class(TCustomAutoDateEdit)
  published
    { Property SelectPeriod must be first. }
    property SelectPeriod;
    property AutoSelect;
    property AutoSize;
    property BeginDate;
    property BorderStyle;
    property Color;
    property Ctl3D;
    property Date;
    property DragCursor;
    property DragMode;
    property DropDownHeight;
    property Enabled;
    property EndDate;
    property Font;
  {$IFDEF DELPHI3_0}
    property ImeMode;
    property ImeName;
  {$ENDIF}
    property ParentColor;
    property ParentCtl3D;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ReadOnly;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property Visible;
    property OnDateChange;
    property OnBeginDateChange;
    property OnEndDateChange;
    property OnChange;
    property OnClick;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnStartDrag;
  end;

{$ENDIF}
  
var
  DateFormat: string;

implementation

const
  NullDate = -700000;

procedure DecMonth(var AYear, AMonth: Word);
begin
  if AMonth = 1 then
  begin
    Dec(AYear);
    AMonth := 12;
  end
  else Dec(AMonth);
end;

procedure IncMonth(var AYear, AMonth: Word);
begin
  if AMonth = 12 then
  begin
    Inc(AYear);
    AMonth := 1;
  end
  else Inc(AMonth);
end;

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

function 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);
end;

{ TAutoDateHintWindow }

type
  TAutoDateHintWindow = class(TCustomControl)
  private
    ACaption: string;
  protected
    procedure CreateParams(var Params: TCreateParams); override;
    procedure Paint; override;
  public
    constructor Create(AOwner: TComponent); override;
    procedure ActivateHint(P: TPoint; const AHint: string); virtual;
    function IsHintMsg(var Msg: TMsg): Boolean; virtual;
  end;

constructor TAutoDateHintWindow.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Color := clWindow; //$80FFFF;
  with Canvas do
  begin
    Font.Name := 'MS Sans Serif';
    Font.Size := 8;
    Brush.Style := bsClear;
  end;
end;

procedure TAutoDateHintWindow.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  with Params do
  begin
    Style := WS_POPUP or {WS_BORDER or} WS_DISABLED;
    WindowClass.Style := WindowClass.Style or CS_SAVEBITS;
    if NewStyleControls then ExStyle := WS_EX_TOOLWINDOW;
  end;
end;

procedure TAutoDateHintWindow.Paint;
var
  R: TRect;
  P: Integer;
  S: string;
begin
  R := ClientRect;

  with Canvas do
  begin
    Pen.Color := clSilver;
    MoveTo(R.Left, R.Bottom);
    LineTo(R.Left, R.Top);
    LineTo(R.Right - 1, R.Top);
    Pen.Color := clBlack;
    LineTo(R.Right - 1, R.Bottom - 1);
    LineTo(R.Left, R.Bottom - 1);
  end;

  Inc(R.Left, 1);
  InflateRect(R, -3, 0);
  Canvas.Font.Color := clInfoText;

  P := Pos(' ', ACaption);
  S := Copy(ACaption, 1, P - 1);
  DrawText(Canvas.Handle, PChar(S), -1, R,
    DT_LEFT or DT_NOPREFIX or DT_SINGLELINE or DT_VCENTER);

  S := Copy(ACaption, P + 1, Length(ACaption) - P);
  DrawText(Canvas.Handle, PChar(S), -1, R,
    DT_RIGHT or DT_NOPREFIX or DT_SINGLELINE or DT_VCENTER);
end;

procedure TAutoDateHintWindow.ActivateHint(P: TPoint; const AHint: string);
var
  AWidth, AHeight: Integer;
  R: TRect;
begin
  AWidth := 90; //Canvas.TextWidth(AHint) + 6;
  AHeight := Canvas.TextHeight(AHint) + 4;
  R.Left := P.X - AWidth;
  R.Right := P.X;
  R.Top := P.Y - AHeight div 2;
  R.Bottom := R.Top + AHeight;

  if R.Bottom > Screen.Height then
    R.Top := Screen.Height - AHeight;
  if R.Right > Screen.Width then
    R.Left := Screen.Width - AWidth;
  if R.Left < 0 then R.Left := 0;
  if R.Top < 0 then R.Top := 0;

  ACaption := AHint;
  SetWindowPos(Handle, HWND_TOPMOST, R.Left, R.Top, AWidth, AHeight,
    SWP_SHOWWINDOW or SWP_NOACTIVATE);
  Repaint;
end;

function TAutoDateHintWindow.IsHintMsg(var Msg: TMsg): Boolean;
begin
  with Msg do
    Result := ((Message >= WM_KEYFIRST) and (Message <= WM_KEYLAST)) or
      ((Message = CM_ACTIVATE) or (Message = CM_DEACTIVATE)) or
      (Message = CM_APPKEYDOWN) or (Message = CM_APPSYSCOMMAND) or
      (Message = WM_COMMAND) or ((Message > WM_MOUSEMOVE) and
      (Message <= WM_MOUSELAST)) or (Message = WM_NCMOUSEMOVE);
end;

{ TCustomAutoDateControl }

constructor TCustomAutoDateControl.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Height := 200;
  TabStop := True;
  FDate := NullDate;
  Date := SysUtils.Date;
  FStartOfWeek := ACLStartOfWeek;
end;

function TCustomAutoDateControl.GetBeginDate: TDateTime;
begin
  if FBeginDate < FEndDate then Result := FBeginDate
  else Result := FEndDate;
end;

function TCustomAutoDateControl.GetEndDate: TDateTime;
begin
  if FEndDate > FBeginDate then Result := FEndDate
  else Result := FBeginDate;
end;

function TCustomAutoDateControl.GetVisibleRowCount: Integer;
begin
  Result := ClientHeight div RowHeight;
end;

function TCustomAutoDateControl.GetWidth: Integer;
begin
  Result := 7 * ColWidth +
    (1 + Byte(not IsPopup)) * 2 * GetSystemMetrics(SM_CXBORDER) +
    GetSystemMetrics(SM_CXVSCROLL);
end;

procedure TCustomAutoDateControl.SetBeginDate(Value: TDateTime);
begin
  if FBeginDate <> Value then
  begin
    if FBeginDate = NullDate then FEndDate := Value;
    FBeginDate := Value;
    if FBeginDate = NullDate then FEndDate := NullDate
    else
      if not SelectPeriod then
      begin
        FEndDate := FBeginDate;
        Date := FBeginDate;
        Exit;
      end;
    Invalidate;
    DoBeginDateChange;
  end;
end;

procedure TCustomAutoDateControl.SetDate(Value: TDateTime);
var
  Row: Integer;
  OldDate: TDateTime;
  OldYear, OldMonth, OldDay, Year, Month, Day: Word;
begin
  if FDate <> Value then
  begin
    Row := 0;
    OldDate := FDate;
    if OldDate > NullDate then Row := RowOfDate(Value);
    FDate := Value;
    if OldDate = NullDate then FTopRow := 0
    else                      
    begin
      DecodeDate(OldDate, OldYear, OldMonth, OldDay);
      DecodeDate(FDate, Year, Month, Day);
      if not ((Year = OldYear) and (Month = OldMonth)) and
        IsWindowVisible(Handle) then
        if csDesigning in ComponentState then FTopRow := 0
        else
        begin
          FTopRow := FTopRow - (Row - RowOfDate(FDate));
          Row := RowOfDate(FDate);
          if Row < FTopRow then FTopRow := Row;
          if Row - FTopRow >= VisibleRowCount then
            FTopRow := Row - (VisibleRowCount - 1);
        end;
    end;
    if not SelectPeriod then
    begin
      FBeginDate := FDate;
      FEndDate := FDate;
    end;
    DoDateChange;
    Invalidate;
  end;
end;

procedure TCustomAutoDateControl.SetEndDate(Value: TDateTime);
begin
  if FEndDate <> Value then
  begin
    FEndDate := Value;
    if not SelectPeriod then
    begin
      FBeginDate := FEndDate;
      Date := FEndDate;
    end
    else
    begin
      Invalidate;
      DoEndDateChange;
    end;
  end;
end;

procedure TCustomAutoDateControl.SetSelectPeriod(Value: Boolean);
begin
  if FSelectPeriod <> Value then
  begin
    FSelectPeriod := Value;
    if not FSelectPeriod then
    begin
      FBeginDate := FDate;
      FEndDate := FDate;