cmoneyinpedt.pas

Delphi功能强的DBGRID构件,支持钱币网格,从DBGRIDEH中继承.比速达的网格构件功能更强大.

unit CMoneyInpEdt;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Buttons, ExtCtrls, Grids, CommCtrl, StdCtrls, RichEdit, ToolWin;

resourcestring
  sDateTimeMax = '日期不能大于 %s';
  sDateTimeMin = '日期最小必须大于 %s';
  sNeedAllowNone = '您必须在 ShowCheckbox 模式下设置这个日期';
  sFailSetCalDateTime = '设置日历的日期或时间失败';
  sFailSetCalMaxSelRange = '设置最大选择范围失败';
  sFailSetCalMinMaxRange = '设置日历最大/最小范围失败';
  sCalRangeNeedsMultiSelect = '日期范围只能在多选择模式下使用';
  sFailsetCalSelRange = '设置日历选择范围失败';
  sInvalidComCtl32 = '需要 COMCTL32.DLL 4.70 或更高版本';

type
  TfrmPopCalculator = class(TForm)
    pnlCalculator: TPanel;
    spbC: TSpeedButton;
    spbCE: TSpeedButton;
    spbBack: TSpeedButton;
    spbPercent: TSpeedButton;
    spbDiv: TSpeedButton;
    spbRide: TSpeedButton;
    spbDec: TSpeedButton;
    spbInc: TSpeedButton;
    spbEnter: TSpeedButton;
    spbDot: TSpeedButton;
    spb0: TSpeedButton;
    spb1: TSpeedButton;
    spb2: TSpeedButton;
    spb3: TSpeedButton;
    spb4: TSpeedButton;
    spb5: TSpeedButton;
    spb6: TSpeedButton;
    spb7: TSpeedButton;
    spb8: TSpeedButton;
    spb9: TSpeedButton;
    spbSqrt: TSpeedButton;
    spbCross: TSpeedButton;
    spbNegative: TSpeedButton;
    procedure FormActivate(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure FormDeactivate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure NumberButtonClick(Sender: TObject);
    procedure spbEnterClick(Sender: TObject);
    procedure spbDotClick(Sender: TObject);
    procedure spbCEClick(Sender: TObject);
    procedure spbBackClick(Sender: TObject);
    procedure OperatorButtonClick(Sender: TObject);
    procedure spbNegativeClick(Sender: TObject);
    procedure spbSqrtClick(Sender: TObject);
    procedure spbCrossClick(Sender: TObject);
  private
    { Private declarations }
  protected
    { Protected declarations }
    procedure CreateParams(var Params: TCreateParams); override;
  public
    { Public declarations }
    A, B, C: Extended;
    D: Integer;
    FInplaceEdit: TInplaceEdit;
    FirstKey: Boolean;
  end;


  TCommonCalendar = class;
  ECommonCalendarError = class(Exception);

  TMonthCalColors = class(TPersistent)
  private
    Owner: TCommonCalendar;
    FBackColor: TColor;
    FTextColor: TColor;
    FTitleBackColor: TColor;
    FTitleTextColor: TColor;
    FMonthBackColor: TColor;
    FTrailingTextColor: TColor;
    procedure SetColor(Index: Integer; Value: TColor);
    procedure SetAllColors;
  public
    constructor Create(AOwner: TCommonCalendar);
    procedure Assign(Source: TPersistent); override;
  published
    property BackColor: TColor index 0 read FBackColor write SetColor default clWindow;
    property TextColor: TColor index 1 read FTextColor write SetColor default clWindowText;
    property TitleBackColor: TColor index 2 read FTitleBackColor write SetColor default clActiveCaption;
    property TitleTextColor: TColor index 3 read FTitleTextColor write SetColor default clWhite;
    property MonthBackColor: TColor index 4 read FMonthBackColor write SetColor default clWhite;
    property TrailingTextColor: TColor index 5 read FTrailingTextColor
      write SetColor default clInactiveCaptionText;
  end;

  TCalDayOfWeek = (dowMonday, dowTuesday, dowWednesday, dowThursday,
    dowFriday, dowSaturday, dowSunday, dowLocaleDefault);

  TOnGetMonthInfoEvent = procedure(Sender: TObject; Month: DWORD;
    var MonthBoldInfo: DWORD) of object;

  TDateTimeColors = TMonthCalColors; 

  TCommonCalendar = class(TWinControl)
  private
    FCalColors: TMonthCalColors;
    FCalExceptionClass: ExceptClass;
    FDateTime: TDateTime;
    FEndDate: TDate;
    FFirstDayOfWeek: TCalDayOfWeek;
    FMaxDate: TDate;
    FMaxSelectRange: Integer;
    FMinDate: TDate;
    FMonthDelta: Integer;
    FMultiSelect: Boolean;
    FShowToday: Boolean;
    FShowTodayCircle: Boolean;
    FWeekNumbers: Boolean;
    FOnGetMonthInfo: TOnGetMonthInfoEvent;
    function DoStoreEndDate: Boolean;
    function DoStoreMaxDate: Boolean;
    function DoStoreMinDate: Boolean;
    function GetDate: TDate;
    procedure SetCalColors(Value: TMonthCalColors);
    procedure SetDate(Value: TDate);
    procedure SetDateTime(Value: TDateTime);
    procedure SetEndDate(Value: TDate);
    procedure SetFirstDayOfWeek(Value: TCalDayOfWeek);
    procedure SetMaxDate(Value: TDate);
    procedure SetMaxSelectRange(Value: Integer);
    procedure SetMinDate(Value: TDate);
    procedure SetMonthDelta(Value: Integer);
    procedure SetMultiSelect(Value: Boolean);
    procedure SetRange(MinVal, MaxVal: TDate);
    procedure SetSelectedRange(Date, EndDate: TDate);
    procedure SetShowToday(Value: Boolean);
    procedure SetShowTodayCircle(Value: Boolean);
    procedure SetWeekNumbers(Value: Boolean);
  protected
    procedure CheckEmptyDate; virtual;
    procedure CheckValidDate(Value: TDate); virtual;
    procedure CreateWnd; override;
    function GetCalendarHandle: HWND; virtual; abstract;
    function GetCalStyles: DWORD; virtual;
    function MsgSetCalColors(ColorIndex: Integer; ColorValue: TColor): Boolean; virtual; abstract;
    function MsgSetDateTime(Value: TSystemTime): Boolean; virtual; abstract;
    function MsgSetRange(Flags: Integer; SysTime: PSystemTime): Boolean; virtual; abstract;
    property CalColors: TMonthCalColors read FCalColors write SetCalColors;
    property CalendarHandle: HWND read GetCalendarHandle;
    property CalExceptionClass: ExceptClass read FCalExceptionClass write FCalExceptionClass;
    property Date: TDate read GetDate write SetDate;
    property DateTime: TDateTime read FDateTime write SetDateTime;
    property EndDate: TDate read FEndDate write SetEndDate stored DoStoreEndDate;
    property FirstDayOfWeek: TCalDayOfWeek read FFirstDayOfWeek write SetFirstDayOfWeek
      default dowLocaleDefault;
    property MaxDate: TDate read FMaxDate write SetMaxDate stored DoStoreMaxDate;
    property MaxSelectRange: Integer read FMaxSelectRange write SetMaxSelectRange default 31;
    property MinDate: TDate read FMinDate write SetMinDate stored DoStoreMinDate;
    property MonthDelta: Integer read FMonthDelta write SetMonthDelta default 1;
    property MultiSelect: Boolean read FMultiSelect write SetMultiSelect default False;
    property ShowToday: Boolean read FShowToday write SetShowToday default True;
    property ShowTodayCircle: Boolean read FShowTodayCircle write
      SetShowTodayCircle default True;
    property WeekNumbers: Boolean read FWeekNumbers write SetWeekNumbers default False;
    property OnGetMonthInfo: TOnGetMonthInfoEvent read FOnGetMonthInfo write FOnGetMonthInfo;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure BoldDays(Days: array of DWORD; var MonthBoldInfo: DWORD);
  end;

{ TMonthCalendar }

  EMonthCalError = class(ECommonCalendarError);

  TMonthCalendar = class(TCommonCalendar)
  private
    procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
    procedure CNNotify(var Message: TWMNotify); message CN_NOTIFY;
  protected
    function CanAutoSize(var NewWidth, NewHeight: Integer): Boolean; override;
    procedure ConstrainedResize(var MinWidth, MinHeight, MaxWidth,
      MaxHeight: Integer);  override;
    procedure CreateParams(var Params: TCreateParams); override;
    function GetCalendarHandle: HWND; override;
    function MsgSetCalColors(ColorIndex: Integer; ColorValue: TColor): Boolean; override;
    function MsgSetDateTime(Value: TSystemTime): Boolean; override;
    function MsgSetRange(Flags: Integer; SysTime: PSystemTime): Boolean; override;
  public
    constructor Create(AOwner: TComponent); override;
  published
    property Align;
    property CalColors;
    property MultiSelect;
    property Date;
    property DragCursor;
    property DragMode;
    property Enabled;
    property EndDate;
    property FirstDayOfWeek;
    property Font;
    property ImeMode;
    property ImeName;
    property MaxDate;
    property MaxSelectRange;
    property MinDate;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property ShowToday;
    property ShowTodayCircle;
    property TabOrder;
    property TabStop;
    property Visible;
    property WeekNumbers;
    property OnClick;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnGetMonthInfo;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnStartDrag;
  end;

var
  frmPopCalculator: TfrmPopCalculator;

implementation

{$R *.DFM}

{ TMonthCalColors }

const
  ColorIndex: array[0..5] of Integer = (MCSC_BACKGROUND, MCSC_TEXT,
    MCSC_TITLEBK, MCSC_TITLETEXT, MCSC_MONTHBK, MCSC_TRAILINGTEXT);

var
  HintHook: HHOOK;

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

function HintGetMsgHook(nCode: Integer; wParam: Longint; var Msg: TMsg): Longint; stdcall;
begin
  Result := CallNextHookEx(HintHook, nCode, wParam, Longint(@Msg));
  if IsHintMsg(Msg) then
    frmPopCalculator.Close;
end;

procedure TfrmPopCalculator.FormActivate(Sender: TObject);
begin
  if HintHook = 0 then
    begin
      frmPopCalculator := Self;
      HintHook := SetWindowsHookEx(WH_GETMESSAGE, @HintGetMsgHook, 0, GetCurrentThreadID);
    end;
end;

procedure TfrmPopCalculator.FormCreate(Sender: TObject);
begin
  HintHook := 0;
  FirstKey := False;
  A := 0;
  B := 0;
  C := 0;
  D := 0;
end;

procedure TfrmPopCalculator.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  Action := CaFree;
end;

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

procedure TfrmPopCalculator.FormDestroy(Sender: TObject);
begin
  if HintHook <> 0 then UnhookWindowsHookEx(HintHook);
end;

procedure TfrmPopCalculator.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  with Params do
    Style := Style or WS_POPUP;
end;

procedure TfrmPopCalculator.NumberButtonClick(Sender: TObject);
var
  c: Integer;
begin
  if FirstKey then
    begin
      FInplaceEdit.Text := '';
      FirstKey := False;
    end;
  c := TComponent(Sender).Tag + Ord('0');
  SendMessage(FInplaceEdit.Handle, WM_CHAR, c, 0);
end;

procedure TfrmPopCalculator.spbEnterClick(Sender: TObject);
begin
  OperatorButtonClick(spbInc);
  Close;
end;

procedure TfrmPopCalculator.spbDotClick(Sender: TObject);
begin
  if FirstKey then
    begin
      FInplaceEdit.Text := '';
      FirstKey := False;
    end;
  SendMessage(FInplaceEdit.Handle, WM_Char, Ord('.'), 0);
end;

procedure TfrmPopCalculator.spbCEClick(Sender: TObject);
begin
  //Raymond 03-17
  FInplaceEdit.Text := '';
  SendMessage(FInplaceEdit.Handle, WM_CLEAR, 0, 0);
end;

procedure TfrmPopCalculator.spbBackClick(Sender: TObject);
begin
  SendMessage(FInplaceEdit.Handle, WM_CHAR, 8, 0);
end;

procedure TfrmPopCalculator.OperatorButtonClick(Sender: TObject);
begin
  if D = 0 then
    begin
      if not TextToFloat(PChar(FInplaceEdit.Text), A, fvExtended) then A := 0;
      D := TComponent(Sender).Tag;
      FirstKey := True;
      Exit;
    end;
  if FirstKey then
    begin
      D := TComponent(Sender).Tag;
      Exit;
    end;
  if not TextToFloat(PChar(FInplaceEdit.Text), B, fvExtended) then B := 0;
  case D of
    1: A := A + B;
    2: A := A - B;
    3: A := A * B;
    4:
      if B = 0 then
        Exit
      else
        A := A / B;
    5:
      if B = 0 then
        Exit
      else
        A := Round(A) mod Round(B);
  end;
  D := TComponent(Sender).Tag;
  FirstKey := True;
  FInplaceEdit.Text := FloatToStr(A);
end;


constructor TMonthCalColors.Create(AOwner: TCommonCalendar);
begin
  Owner := AOwner;
  FBackColor := clWindow;
  FTextColor := clWindowText;
  FTitleBackColor := clActiveCaption;
  FTitleTextColor := clWhite;
  FMonthBackColor := clWhite;
  FTrailingTextColor := clInactiveCaptionText;
end;

procedure TMonthCalColors.Assign(Source: TPersistent);
var
  SourceName: string;
begin
  if Source = nil then
    SourceName := 'nil'
  else
    SourceName := Source.ClassName;
  if (Source = nil) or not (Source is TMonthCalColors) then
    raise EConvertError.CreateFmt('Cannot assign a %s to a %s', [SourceName, ClassName]);
  FBackColor := TMonthCalColors(Source).BackColor;
  FTextColor := TMonthCalColors(Source).TextColor;
  FTitleBackColor := TMonthCalColors(Source).TitleBackColor;
  FTitleTextColor := TMonthCalColors(Source).TitleTextColor;
  FMonthBackColor := TMonthCalColors(Source).MonthBackColor;
  FTrailingTextColor := TMonthCalColors(Source).TrailingTextColor;
end;

procedure TMonthCalColors.SetColor(Index: Integer; Value: TColor);
begin
  case Index of
    0: FBackColor := Value;
    1: FTextColor := Value;
    2: FTitleBackColor := Value;
    3: FTitleTextColor := Value;
    4: FMonthBackColor := Value;
    5: FTrailingTextColor := Value;
  end;
  if Owner.HandleAllocated then
    Owner.MsgSetCalColors(ColorIndex[Index], ColorToRGB(Value));
end;

procedure TMonthCalColors.SetAllColors;
begin
  SetColor(0, FBackColor);
  SetColor(1, FTextColor);
  SetColor(2, FTitleBackColor);
  SetColor(3, FTitleTextColor);
  SetColor(4, FMonthBackColor);
  SetColor(5, FTrailingTextColor);
end;

{ TCommonCalendar }

function InitCommonControl(CC: Integer): Boolean;
var
  ICC: TInitCommonControlsEx;
begin
  ICC.dwSize := SizeOf(TInitCommonControlsEx);
  ICC.dwICC := CC;
  Result := InitCommonControlsEx(ICC);
  if not Result then InitCommonControls;
end;

procedure CheckCommonControl(CC: Integer);
begin
  if not InitCommonControl(CC) then
    raise EComponentError.Create(SInvalidComCtl32);
end;

constructor TCommonCalendar.Create(AOwner: TComponent);
begin
  CheckCommonControl(ICC_DATE_CLASSES);
  inherited Create(AOwner);
  FShowToday := True;