shenhotkeys.pas

来自「向程序发送热键的单元源程序」· PAS 代码 · 共 732 行 · 第 1/2 页

{-----------------------------------------------------------------------------
 Unit Name: ShenHotKeys
 Author:    slq (沈龙强)
 E-Mail:    [e-mail]
 Homepage:  http://shenloqi.delphibbs.com
            http://www.shen.h58.net
 Purpose:   系统级的热键控件，可以运行于Win98,Win2000,WinXP。
            直接支持TShortcut。
            还有一部分键值没有包括进去。
            安排热键超过10个的时候将会出现小问题，但是可以手工调整，暂时不修正。
 History:
-----------------------------------------------------------------------------}

unit ShenHotKeys;

interface

uses
  Classes, Windows, {$IFDEF VER140}designintf, vcleditors,
    designeditors{$ELSE}DsgnIntf{$ENDIF}, Messages, Forms, ComCtrls;

type
  //辅助键类别
  TShenShiftState = set of (ssShift, ssAlt, ssCtrl);

  //前置声明
  TShenHotKeys = class;

  //热键项目
  TShenHotKeyItem = class(TCollectionItem)
  private
    FHotKeyId: Integer;
    FOnHotKey: TNotifyEvent;
    FName: string;
    FHotKey: Integer;
    FShiftState: TShenShiftState;
    procedure SetShiftState(State: TShenShiftState);
    function GetHotKey: string;
    procedure SetHotKey(Key: string);
    function GetManager: TShenHotKeys;
  protected
    function GetDisplayName: string; override;
    procedure RegisterHotKey;
    procedure UnRegisterHotKey;
    property HotKeyId: Integer read FHotKeyId;
    property Manager: TShenHotKeys read GetManager;
  public
    function GetNamePath: string; override;
    function ShortcuttoHotkeys(Shortcut: tshortcut): Boolean;
    procedure Assign(Item: TPersistent); override;
  published
    property Name: string read FName write FName;
    property ShiftState: TShenShiftState read FShiftState write SetShiftState;
    property HotKey: string read GetHotKey write SetHotKey;
    property OnHotKeyActivation: TNotifyEvent read FOnHotKey write FOnHotKey;
  end;

  //聚集类
  THotKeyCollection = class(TCollection)
  private
    FOwner: TShenHotKeys;
    function GetItem(Idx: Integer): TShenHotKeyItem;
    procedure SetItem(Idx: Integer; Item: TShenHotKeyItem);
  protected
    function GetOwner: TPersistent; override;
  public
    constructor Create(Manager: TShenHotKeys);
    property Items[Idx: Integer]: TShenHotKeyItem read GetItem write SetItem;
      default;
  end;

  //
  TShenHotKeys = class(TComponent)
  private
    FHotKeys: THotKeyCollection;
    procedure SetHotKeys(HotKeys: THotKeyCollection);
    function WMHotKey(var Msg: TMessage): Boolean;
  protected
    procedure Loaded; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function HotKeyByName(const Name: string): TShenHotKeyItem;
  published
    property HotKeys: THotKeyCollection read FHotKeys write SetHotKeys;
  end;

procedure Register;

implementation

uses SysUtils, TypInfo;

const
  //这次采用了与ShenCpls不同的方法
  KeyCodes: array[0..77] of Integer =
  (0, Ord('A'), Ord('B'), Ord('C'), Ord('D'), Ord('E'), Ord('F'), Ord('G'),
    Ord('H'), Ord('I'), Ord('J'), Ord('K'), Ord('L'), Ord('M'), Ord('N'),
    Ord('O'), Ord('P'), Ord('Q'), Ord('R'), Ord('S'), Ord('T'), Ord('U'),
    Ord('V'), Ord('W'), Ord('X'), Ord('Y'), Ord('Z'), Ord('1'), Ord('2'),
    Ord('3'), Ord('4'), Ord('5'), Ord('6'), Ord('7'), Ord('8'), Ord('9'),
    Ord('0'), VK_F1, VK_F2, VK_F3, VK_F4, VK_F5, VK_F6, VK_F7, VK_F8, VK_F9,
    VK_F10, VK_F11, VK_F12, VK_UP, VK_DOWN, VK_LEFT, VK_RIGHT, VK_ESCAPE, VK_TAB,
    VK_INSERT, VK_DELETE, VK_HOME, VK_END, VK_PRIOR, VK_NEXT, VK_NumPad0,
    VK_NumPad1, VK_NumPad2, VK_NumPad3, VK_NumPad4, VK_NumPad5, VK_NumPad6,
    VK_NumPad7, VK_NumPad8, VK_NumPad9, VK_ADD, VK_SUBTRACT, VK_MULTIPLY,
    VK_DIVIDE, VK_DECIMAL, VK_NUMLOCK, VK_SCROLL);

  KeyLabels: array[0..77] of string =
  ('', 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O',
    'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', 'X', 'Y', 'Z', '1', '2', '3', '4', '5',
    '6', '7', '8', '9', '0', 'F1', 'F2', 'F3', 'F4', 'F5', 'F6', 'F7', 'F8', 'F9',
    'F10', 'F11', 'F12', 'Up', 'Down', 'Left', 'Right', 'Echap', 'Tab', 'Insert',
    'Delete', 'Home', 'End', 'Page up', 'Page down', 'NumPad 0', 'NumPad 1',
    'NumPad 2', 'NumPad 3', 'NumPad 4', 'NumPad 5', 'NumPad 6', 'NumPad 7',
    'NumPad 8', 'NumPad 9', 'NumPad +', 'NumPad -', 'NumPad *', 'NumPad /',
    'NumPad .', 'NumLock', 'ScrollLock');

{-----------------------------------------------------------------------------
  Procedure: TShenHotKeys.Create
  Author:    slq
  Date:      08-三月-2002
  Arguments: AOwner: TComponent
  Result:    None
  Purpose:   构造函数，判断是否处于设计期
-----------------------------------------------------------------------------}

constructor TShenHotKeys.Create(AOwner: TComponent);
begin
  FHotKeys := THotKeyCollection.Create(Self);
  inherited Create(AOwner);
  if not (csDesigning in ComponentState) then
    Application.HookMainWindow(WMHotKey);
end;

{-----------------------------------------------------------------------------
  Procedure: TShenHotKeys.Destroy
  Author:    slq
  Date:      08-三月-2002
  Arguments: None
  Result:    None
  Purpose:   析构函数
-----------------------------------------------------------------------------}

destructor TShenHotKeys.Destroy;
var i: Integer;
begin
  if not (csDesigning in ComponentState) then
    Application.UnHookMainWindow(WMHotKey);
  for i := 0 to HotKeys.Count - 1 do
    HotKeys[i].UnRegisterHotKey;
  FHotKeys.Free; FHotKeys := nil;
  inherited Destroy;
end;

{-----------------------------------------------------------------------------
  Procedure: TShenHotKeys.WMHotKey
  Author:    slq
  Date:      08-三月-2002
  Arguments: var Msg: TMessage
  Result:    Boolean
  Purpose:   激活热键触发事件
-----------------------------------------------------------------------------}

function TShenHotKeys.WMHotKey(var Msg: TMessage): Boolean;
var i: Integer;
begin
  if Msg.Msg = WM_HOTKEY then
  begin
    for i := 0 to HotKeys.Count - 1 do
      if Msg.wParam = HotKeys[i].HotKeyId then
      begin
        Result := True;
        if Assigned(HotKeys[i].OnHotKeyActivation) then
          HotKeys[i].OnHotKeyActivation(HotKeys[i]);
        Exit;
      end;
  end;
  Result := False;
end;

{-----------------------------------------------------------------------------
  Procedure: TShenHotKeys.Loaded
  Author:    slq
  Date:      08-三月-2002
  Arguments: None
  Result:    None
  Purpose:   重载Tcomponent的Loaded函数。
-----------------------------------------------------------------------------}

procedure TShenHotKeys.Loaded;
var i: Integer;
begin
  inherited Loaded;
  if not (csDesigning in ComponentState) then
    for i := 0 to HotKeys.Count - 1 do
      HotKeys[i].RegisterHotKey;
end;

{-----------------------------------------------------------------------------
  Procedure: TShenHotKeys.HotKeyByName
  Author:    slq
  Date:      08-三月-2002
  Arguments: const Name: string
  Result:    TShenHotKeyItem
  Purpose:   解析
-----------------------------------------------------------------------------}

function TShenHotKeys.HotKeyByName(const Name: string): TShenHotKeyItem;
var i: Integer;
begin
  for i := 0 to HotKeys.Count - 1 do
    if CompareText(Name, HotKeys[i].Name) = 0 then
    begin
      Result := HotKeys[i];
      Exit;
    end;
  Result := nil;
end;

{-----------------------------------------------------------------------------
  Procedure: TShenHotKeys.SetHotKeys
  Author:    slq
  Date:      08-三月-2002
  Arguments: HotKeys: THotKeyCollection
  Result:    None
  Purpose:   assign
-----------------------------------------------------------------------------}

procedure TShenHotKeys.SetHotKeys(HotKeys: THotKeyCollection);
begin
  FHotKeys.Assign(HotKeys);
end;

{ THotKeyCollection }

{-----------------------------------------------------------------------------
  Procedure: THotKeyCollection.Create
  Author:    slq
  Date:      08-三月-2002
  Arguments: Manager: TShenHotKeys
  Result:    None
  Purpose:   构造函数
-----------------------------------------------------------------------------}

constructor THotKeyCollection.Create(Manager: TShenHotKeys);
begin
  FOwner := Manager;
  inherited Create(TShenHotKeyItem);
end;

{-----------------------------------------------------------------------------
  Procedure: THotKeyCollection.GetItem
  Author:    slq
  Date:      08-三月-2002
  Arguments: Idx: Integer
  Result:    TShenHotKeyItem
  Purpose:
-----------------------------------------------------------------------------}

function THotKeyCollection.GetItem(Idx: Integer): TShenHotKeyItem;
begin
  Result := TShenHotKeyItem(inherited Items[Idx]);
end;

{-----------------------------------------------------------------------------
  Procedure: THotKeyCollection.GetOwner
  Author:    slq
  Date:      08-三月-2002
  Arguments: None
  Result:    TPersistent
  Purpose:
-----------------------------------------------------------------------------}

function THotKeyCollection.GetOwner: TPersistent;
begin
  Result := FOwner;
end;

{-----------------------------------------------------------------------------
  Procedure: THotKeyCollection.SetItem
  Author:    slq
  Date:      08-三月-2002
  Arguments: Idx: Integer; Item: TShenHotKeyItem
  Result:    None
  Purpose:
-----------------------------------------------------------------------------}

procedure THotKeyCollection.SetItem(Idx: Integer; Item: TShenHotKeyItem);
begin
  inherited Items[Idx] := Item;
end;

{ THotKeyItem }

{-----------------------------------------------------------------------------
  Procedure: TShenHotKeyItem.RegisterHotKey
  Author:    slq
  Date:      08-三月-2002
  Arguments: None
  Result:    None
  Purpose:   向系统注册
-----------------------------------------------------------------------------}

procedure TShenHotKeyItem.RegisterHotKey;
var Shift: Integer;
  Key: Integer;
begin
  if FHotKeyId <> 0 then
    UnRegisterHotKey;
  if FHotKey <> 0 then
  begin
    Shift := 0;
    if ssAlt in ShiftState then
      Shift := Shift + MOD_ALT;
    if ssCtrl in ShiftState then
      Shift := Shift + MOD_CONTROL;
    if ssShift in ShiftState then
      Shift := Shift + MOD_SHIFT;
    Key := KeyCodes[FHotKey];
    FHotKeyId := $A000 + ID;
    Windows.RegisterHotKey(Application.Handle, FHotKeyId, Shift, Key);
  end;
end;

{-----------------------------------------------------------------------------
  Procedure: TShenHotKeyItem.UnRegisterHotKey
  Author:    slq
  Date:      08-三月-2002
  Arguments: None
  Result:    None
  Purpose:   取消系统中的注册
-----------------------------------------------------------------------------}

procedure TShenHotKeyItem.UnRegisterHotKey;
begin
  if FHotKeyId <> 0 then
  begin
    Windows.UnRegisterHotKey(Application.Handle, FHotKeyId);
    FHotKeyId := 0;
  end;
end;

{-----------------------------------------------------------------------------
  Procedure: TShenHotKeyItem.ShortcuttoHotkeys
  Author:    slq
  Date:      08-三月-2002
  Arguments: Shortcut:TShortcut
  Result:    Boolean
  Purpose:   转换TShortcut与热键，采用的也是一种笨方法：）
-----------------------------------------------------------------------------}

function TShenHotKeyItem.ShortcuttoHotkeys(Shortcut: TShortcut): Boolean;
var
  tempshift, tempshiftold: TShenShiftState;
  temphotkey, temphotkeyold: string;
  W: Word;
begin
  tempshiftold := ShiftState;
  temphotkeyold := hotkey;
  try
    tempshift := [];
    if Shortcut and scShift <> 0 then tempshift := tempshift + [ssShift];
    if Shortcut and scCtrl <> 0 then tempshift := tempshift + [ssctrl];
    if Shortcut and scAlt <> 0 then tempshift := tempshift + [ssAlt];
    W := Shortcut and not (scShift + scCtrl + scAlt);