aqtyper.pas

来自「delphi编程控件」· PAS 代码 · 共 500 行

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

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, Mask, ExtCtrls, DBCtrls, DB, Menus;

type

TAutoQuickTyper = class(TComponent)
private
  FWinControl : TWinControl;
  FMessageBeep : Boolean;

  procedure SetWinControl(Value : TWinControl);
protected
  function Execute(flag : Boolean) : Boolean;
public
  constructor Create(AOwner : TComponent); override;
  destructor Destroy; override;
  procedure Notification(AComponent: TComponent; Operation: TOperation); override;
published
  property WinControl : TWinControl read FWinControl write SetWinControl;
  property MessageBeep : Boolean read FMessageBeep write FMessageBeep;
end;

TDBQuickTyperOption = (qtoDBMove, qtoConfirmDel, qtoReturn);
TDBQuickTyperOptions = set of TDBQuickTyperOption;

TAutoDBQuickTyper = class(TAutoQuickTyper)
private
  FDataLink : TDataLink;
  FOptions : TDBQuickTyperOptions;
  FRecordPerPage : Integer;
  FCancelKey : TShortCut;
  FDeleteKey : TShortCut;
  FInsertKey : TShortCut;
  FPostKey : TShortCut;  

  function GetDataSource : TDataSource;
  procedure SetDataSource(Value : TDataSource);
  procedure SetRecordPerPage(Value : Integer);
protected
  function DBExecute(wparam : LongInt) : Boolean;
public
  constructor Create(AOwner : TComponent); override;
  destructor Destroy; override;
  procedure Notification(AComponent: TComponent; Operation: TOperation); override;
published
  property DataSource : TDataSource read GetDataSource write SetDataSource;
  property RecordPerPage : Integer read FRecordPerPage write SetRecordPerPage;
  property CancelKey : TShortCut read FCancelKey write FCancelKey;
  property DeleteKey : TShortCut read FDeleteKey write FDeleteKey;
  property InsertKey : TShortCut read FInsertKey write FInsertKey;
  property PostKey : TShortCut read FPostKey write FPostKey;  
  property Options : TDBQuickTyperOptions read FOptions write FOptions;
end;

implementation
uses audbstrs, aclconst;

type
TQuickTyperRegister = class
private
  List : TList;
  ObjectInstance : Pointer;
  ActiveControlWndProcAdd : Pointer;
  ActiveControl : TWinControl;
  ActiveControlEnterFlag : Boolean;
  BuzyFlag : Boolean; 
protected
  function GetQuickTyperByWinControl(WinControl : TWinControl) : TAutoQuickTyper;
  procedure ActiveControlWndProc(var Message: TMessage);
  function IsEditControl(WinControl : TWinControl) : Boolean;
public
  constructor Create;
  destructor Destroy; override;
  function Execute(flag : Boolean) : Boolean;
  function DBExecute(wparam : LongInt) : Boolean;
  procedure SetActiveControl;
end;

Var
  QuickTyperRegister : TQuickTyperRegister;
  qtHookKey : HHOOK;
  qtHookWnd : HHOOK;
  qtCount : Integer;

function qtWinProcKey(code: Integer; wparam: WParam; lparam: LParam): LResult; stdcall;
Var
  flag : Boolean;
begin
  Result := -1;
  flag := False;
  if (wparam = VK_RETURN) then  begin
    flag := QuickTyperRegister.Execute((lparam and 1073741824) = 0);
    if(Flag) then
      Result := -1;
  end;
  if(GetKeyState(VK_CONTROL) < 0) And ((lparam and 1073741824) = 0) then begin
    flag := QuickTyperRegister.DBExecute(wparam);
    if(Flag) then
      Result := -1;
  end;
  if Not Flag then
    Result := CallNextHookEx(qtHookKey, code, wparam, lparam);
end;

function qtWinProcWnd(code: Integer; wparam: WParam; lparam: LParam): LResult; stdcall;
begin
  CallNextHookEx(qtHookWnd, code, wparam, lparam);
  QuickTyperRegister.SetActiveControl;
  Result := 0;
end;

procedure QuickTyperAddtoRegister(QuickTyper : TAutoQuickTyper);
begin
  if(qtCount = 0) then
    QuickTyperRegister := TQuickTyperRegister.Create;
  Inc(qtCount);
  QuickTyperRegister.List.Add(QuickTyper);
end;

procedure QuickTyperRemoveFromRegister(QuickTyper : TAutoQuickTyper);
begin
  QuickTyperRegister.List.Remove(QuickTyper);
  Dec(qtCount);
  if(qtCount = 0) then
    QuickTyperRegister.Free;
end;

{TQuickTypeRegister}
constructor TQuickTyperRegister.Create; 
begin
  qtHookKey := SetWindowsHookEx(WH_KEYBOARD, qtWinProcKey, 0, GetCurrentThreadId);
  qtHookWnd := SetWindowsHookEx(WH_CALLWNDPROC, qtWinProcWnd, 0, GetCurrentThreadId);
  List := TList.Create;
  ActiveControl := Nil;
  ActiveControlWndProcAdd := Nil;
  ObjectInstance := MakeObjectInstance(ActiveControlWndProc);
  BuzyFlag := False;
end;

destructor TQuickTyperRegister.Destroy;
begin
  List.Free;
  UnhookWindowsHookEx(qtHookKey);
  UnhookWindowsHookEx(qtHookWnd);
  if (ObjectInstance <> Nil) then
    FreeObjectInstance(ObjectInstance);
  inherited Destroy;
end;

procedure TQuickTyperRegister.SetActiveControl;
begin
  if(ActiveControl = Screen.ActiveControl) then exit;
  if(ActiveControl <> Nil) And (ActiveControlWndProcAdd <> Nil) then begin
    SetWindowLong(ActiveControl.Handle, GWL_WNDPROC, LongInt(ActiveControlWndProcAdd));
    ActiveControlWndProcAdd := Nil;
  end;
  ActiveControl := Screen.ActiveControl;
  if(ActiveControl <> Nil) And (ActiveControl is TCustomEdit) And
  Not (csDesigning in ActiveControl.ComponentState) And
  (GetQuickTyperByWinControl(ActiveControl) <> Nil)then begin
    ActiveControlWndProcAdd := Pointer(GetWindowLong(ActiveControl.Handle, GWL_WNDPROC));
    SetWindowLong(ActiveControl.Handle, GWL_WNDPROC, LongInt(ObjectInstance));
  end;
end;

function TQuickTyperRegister.IsEditControl(WinControl : TWinControl) : Boolean;
begin
  if Not (((WinControl is TCustomEdit) and Not (WinControl is TCustomMemo))
  or (WinControl is TCustomCheckBox)  or (WinControl is TRadioButton)
  or (WinControl is TCustomRadioGroup)) then begin
    Result := False
  end else Result := True;

end;

function TQuickTyperRegister.GetQuickTyperByWinControl(WinControl : TWinControl) : TAutoQuickTyper;
Var
  i : Integer;
  qt : TAutoQuickTyper;

begin
  Result := Nil;
  if(WinControl = Nil) then exit;
  for i := 0 to  List.Count - 1 do begin
    qt := TAutoQuickTyper(List[i]);
    if(qt.WinControl <> Nil) and
    ((WinControl = qt.WinControl) or
      qt.WinControl.ContainsControl(WinControl)) then begin
      Result := qt;
      break;
    end;
  end;

end;

function TQuickTyperRegister.Execute(flag : Boolean) : Boolean;
Var
  ct : TWinControl;
  qt : TAutoQuickTyper;
begin
  Result := False;
  if BuzyFlag then exit;

  if (Screen.ActiveForm = Nil) or
  (csDesigning in Screen.ActiveForm.ComponentState) then   exit;

  ct := Screen.ActiveControl;

  if ActiveControlEnterFlag then begin
    ActiveControlEnterFlag := False;
    Result := IsEditControl(ct);
    exit;
  end;

  if Not IsEditControl(ct)  then exit;

  BuzyFlag := True;
  qt := GetQuickTyperByWinControl(ct);
  if(qt <> Nil) And (Not (qt is TAutoDBQuickTyper)
  Or (qtoReturn in TAutoDBQuickTyper(qt).Options)) then
    Result := qt.Execute(flag);
  BuzyFlag := False;    
end;

function TQuickTyperRegister.DBExecute(wparam : LongInt) : Boolean;
Var
  ct : TWinControl;
  qt : TAutoQuickTyper;
begin
  Result := False;

  if (Screen.ActiveForm = Nil) or
  (csDesigning in Screen.ActiveForm.ComponentState) then   exit;

  ct := Screen.ActiveControl;

  if Not IsEditControl(ct)  then exit;

  qt := GetQuickTyperByWinControl(ct);
  if(qt <> Nil) And (qt is TAutoDBQuickTyper) then
    Result := TAutoDBQuickTyper(qt).DBExecute(wparam);
end;


procedure TQuickTyperRegister.ActiveControlWndProc(var Message: TMessage);
Var
  OldLen, NewLen, MaxLen : Integer;
  qt : TAutoQuickTyper;
  ShiftFlag : Boolean;
  OldShiftValue : Byte;
  KeyState : TKeyboardState;
begin
 with TMessage(Message) do begin
   if(msg = CM_ENTER) then
     ActiveControlEnterFlag := True;
   if(Msg = WM_CHAR) Or (Msg = WM_KEYDOWN)  Or (Msg = WM_KEYUP) then
     ActiveControlEnterFlag := False;
   OldLen := Length(TCustomEdit(ActiveControl).Text);
   Result := CallWindowProc(ActiveControlWndProcAdd, ActiveControl.Handle, Msg, WParam, LParam);
   if(Msg = WM_CHAR) then begin
     NewLen := Length(TCustomEdit(ActiveControl).Text);
     if(ActiveControl is TDBEdit) And (TDBEdit(ActiveControl).Field <> Nil) then
       MaxLen := TDBEdit(ActiveControl).Field.DisplayWidth
     else MaxLen := TEdit(ActiveControl).MaxLength;
     if (MaxLen > 0) And  (NewLen <> OldLen) And
     (MaxLen <= NewLen) then begin
       qt := GetQuickTyperByWinControl(ActiveControl);
       //Does the shift is down ?
       if(GetKeyState(VK_SHIFT) < 0) then begin
         //Remove from keybord state the shift flag
         ShiftFlag := True;
         GetKeyboardState(KeyState);
         OldShiftValue := KeyState[VK_SHIFT];
         KeyState[VK_SHIFT] := 0;
         SetKeyboardState(KeyState);
       end else begin
         ShiftFlag := False;
         OldShiftValue := 0;
       end;

       Screen.ActiveForm.Perform( CM_DIALOGKEY, VK_TAB, 0);
       if(ShiftFlag) then begin
         //Set to keybord state the shift flag       
         KeyState[VK_SHIFT] := OldShiftValue;
         SetKeyboardState(KeyState);
       end;
       if(qt <> Nil) And (qt.FMessageBeep) then
         MessageBeep(MB_OK);
     end;
   end;
 end;
end;

{TAutoQuickTyper}
constructor TAutoQuickTyper.Create(AOwner : TComponent);
begin
  inherited Create(AOwner);
  QuickTyperAddtoRegister(self);
  if(AOwner is TWinControl) then
    FWinControl := TWinControl(AOwner)
  else FWinControl := Nil;
end;

destructor TAutoQuickTyper.Destroy;
begin
  QuickTyperRemoveFromRegister(self);
  inherited Destroy;
end;

procedure TAutoQuickTyper.Notification(AComponent: TComponent; Operation: TOperation);
begin
  inherited;
  if(AComponent = FWinControl) And (Operation = opRemove) then
    FWinControl := Nil;
end;

function TAutoQuickTyper.Execute(flag : Boolean) : Boolean;
begin
  Result := flag;
  if Not flag then begin
    Result := True;
    Screen.ActiveForm.Perform( CM_DIALOGKEY, VK_TAB, 0);
  end;
end;

procedure TAutoQuickTyper.SetWinControl(Value : TWinControl);
begin
  if(FWinControl = Value) then exit;
  FWinControl := Value;
end;

{TAutoDBQuickTyper}
constructor TAutoDBQuickTyper.Create(AOwner : TComponent);
begin
  FDataLink := TDataLink.Create;
  inherited Create(AOwner);
  
  FRecordPerPage := 10;
  FOptions := [qtoDBMove, qtoConfirmDel, qtoReturn];
  FCancelKey := TextToShortcut(ACLQTSTR_CANCEL);
  FDeleteKey := TextToShortcut(ACLQTSTR_DELETE);
  FInsertKey := TextToShortcut(ACLQTSTR_INSERT);
  FPostKey := TextToShortcut(ACLQTSTR_POST);
end;

destructor TAutoDBQuickTyper.Destroy;
begin
  FDataLink.Free;
  inherited Destroy;
end;

procedure TAutoDBQuickTyper.Notification(AComponent: TComponent; Operation: TOperation);
begin
  inherited;
  if(AComponent = DataSource) And (Operation = opRemove) then
    DataSource := Nil;
end;

function TAutoDBQuickTyper.GetDataSource : TDataSource;
begin
  Result := FDataLink.DataSource;
end;

procedure TAutoDBQuickTyper.SetDataSource(Value : TDataSource);
begin
  FDataLink.DataSource := Value;
end;

procedure TAutoDBQuickTyper.SetRecordPerPage(Value : Integer);
begin
  if(Value > 1) then
    FRecordPerPage := Value;
end;

function TAutoDBQuickTyper.DBExecute(wparam : LongInt) : Boolean;
Var
  AShortCut : TShortCut;
begin
  Result := False;
  if FDataLink.Active then begin
    AShortCut := ShortCut(wparam, [ssCtrl]);
    if (CancelKey = AShortCut) then begin
      if(FDataLink.Editing) then begin
        FDataLink.DataSet.Cancel;
        Result := True;
      end;
      exit;
    end;
    if (FDeleteKey = AShortCut) then begin
      if Not (FDataLink.ReadOnly) then begin
        if Not (qtoConfirmDel in FOptions)
        Or (MessageDlg(LoadStr(ACDB_GRIDDELETERECORD), mtConfirmation, [mbOk, mbCancel], -1) = mrOk) then
           try
             FDataLink.DataSet.Delete;
           except
             raise;
           end;
        Result := True;
      end;
      exit;
    end;
    if (FInsertKey = AShortCut) then begin
      if Not (FDataLink.ReadOnly)then begin
        try
          FDataLink.DataSet.Insert;
        except
          raise;
         end;
        Result := True;
      end;
      exit;
    end;
    if (FPostKey = AShortCut) then begin
      if (FDataLink.Editing)then begin
        try
          FDataLink.DataSet.Post;
        except
          raise;
         end;
        Result := True;
      end;
      exit;
    end;

    if (qtoDBMove in FOptions) then
      case wparam of
        VK_UP, VK_LEFT :
        begin
          try
            FDataLink.DataSet.Prior;
          except
             raise;
           end;
          Result := True;
        end;
        VK_DOWN, VK_RIGHT:
        begin
           try
            FDataLink.DataSet.Next;
           except
             raise;
           end;
          Result := True;
        end;
      VK_HOME:
        begin
          try
            FDataLink.DataSet.First;
           except
             raise;
           end;
          Result := True;
        end;
      VK_END:
        begin
        try
          FDataLink.DataSet.Last;
           except
             raise;
           end;
          Result := True;
        end;
      VK_PRIOR:
        begin
        try
          FDataLink.DataSet.MoveBy(-FRecordPerPage);
           except
             raise;
           end;
          Result := True;
        end;
      VK_NEXT:
        begin
        try
          FDataLink.DataSet.MoveBy(FRecordPerPage);
           except
             raise;
           end;
          Result := True;
        end;
    end;
  end;
end;


initialization
  qtCount := 0;

end.