我以前增强的一个控件。不要告诉我不会装控件吧。
http://loqi.myetang.com/html/zzkj.htm里有一些我以前做的控件。
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 do
wn', '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.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.HotKeyId then
begin
Result := True;
if Assigned(HotKeys.OnHotKeyActivation) then
HotKeys.OnHotKeyActivation(HotKeys);
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.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.Name) = 0 then
begin
Result := HotKeys;
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);
case W of
0: temphotkey := keylabels[0];
Ord('A'): temphotkey := keylabels[1];
Ord('B'): temphotkey := keylabels[2];
Ord('C'): temphotkey := keylabels[3];
Ord('D'): temphotkey := keylabels[4];
Ord('E'): temphotkey := keylabels[5];
Ord('F'): temphotkey := keylabels[6];
Ord('G'): temphotkey := keylabels[7];
Ord('H'): temphotkey := keylabels[8];
Ord('I'): temphotkey := keylabels[9];
Ord('J'): temphotkey := keylabels[10];
Ord('K'): temphotkey := keylabels[11];
Ord('L'): temphotkey := keylabels[12];
Ord('M'): temphotkey := keylabels[13];
Ord('N'): temphotkey := keylabels[14];
Ord('O'): temphotkey := keylabels[15];
Ord('P'): temphotkey := keylabels[16];
Ord('Q'): temphotkey := keylabels[17];
Ord('R'): temphotkey := keylabels[18];
Ord('S'): temphotkey := keylabels[19];
Ord('T'): temphotkey := keylabels[20];
Ord('U'): temphotkey := keylabels[21];
Ord('V'): temphotkey := keylabels[22];
Ord('W'): temphotkey := keylabels[23];
Ord('X'): temphotkey := keylabels[24];
Ord('Y'): temphotkey := keylabels[25];
Ord('Z'): temphotkey := keylabels[26];
Ord('1'): temphotkey := keylabels[27];
Ord('2'): temphotkey := keylabels[28];
Ord('3'): temphotkey := keylabels[29];
Ord('4'): temphotkey := keylabels[30];
Ord('5'): temphotkey := keylabels[31];
Ord('6'): temphotkey := keylabels[32];
Ord('7'): temphotkey := keylabels[33];
Ord('8'): temphotkey := keylabels[34];
Ord('9'): temphotkey := keylabels[35];
Ord('0'): temphotkey := keylabels[36];
VK_F1: temphotkey := keylabels[37];
VK_F2: temphotkey := keylabels[38];
VK_F3: temphotkey := keylabels[39];
VK_F4: temphotkey := keylabels[40];
VK_F5: temphotkey := keylabels[41];
VK_F6: temphotkey := keylabels[42];
VK_F7: temphotkey := keylabels[43];
VK_F8: temphotkey := keylabels[44];
VK_F9: temphotkey := keylabels[45];
VK_F10: temphotkey := keylabels[46];
VK_F11: temphotkey := keylabels[47];
VK_F12: temphotkey := keylabels[48];
VK_UP: temphotkey := keylabels[49];
VK_DOWN: temphotkey := keylabels[50];
VK_LEFT: temphotkey := keylabels[51];
VK_RIGHT: temphotkey := keylabels[52];
VK_ESCAPE: temphotkey := keylabels[53];
VK_TAB: temphotkey := keylabels[54];
VK_INSERT: temphotkey := keylabels[55];
VK_DELETE: temphotkey := keylabels[56];
VK_HOME: temphotkey := keylabels[57];
VK_END: temphotkey := keylabels[58];
VK_PRIOR: temphotkey := keylabels[59];
VK_NEXT: temphotkey := keylabels[60];
VK_NumPad0: temphotkey := keylabels[61];
VK_NumPad1: temphotkey := keylabels[62];
VK_NumPad2: temphotkey := keylabels[63];
VK_NumPad3: temphotkey := keylabels[64];
VK_NumPad4: temphotkey := keylabels[65];
VK_NumPad5: temphotkey := keylabels[66];
VK_NumPad6: temphotkey := keylabels[67];
VK_NumPad7: temphotkey := keylabels[68];
VK_NumPad8: temphotkey := keylabels[69];
VK_NumPad9: temphotkey := keylabels[70];
VK_ADD: temphotkey := keylabels[71];
VK_SUBTRACT: temphotkey := keylabels[72];
VK_MULTIPLY: temphotkey := keylabels[73];
VK_DIVIDE: temphotkey := keylabels[74];
VK_DECIMAL: temphotkey := keylabels[75];
VK_NUMLOCK: temphotkey := keylabels[76];
VK_SCROLL: temphotkey := keylabels[77];
else
begin
Result := False;
Exit;
end;
end;
ShiftState := tempshift;
HotKey := temphotkey;
Result := True;
except
ShiftState := tempshiftold;
HotKey := temphotkeyold;
Result := False;
end;
end;
{-----------------------------------------------------------------------------
Procedure: TShenHotKeyItem.Assign
Author: slq
Date: 08-三月-2002
Arguments: Item: TPersistent
Result: None
Purpose: 安置
-----------------------------------------------------------------------------}
procedure TShenHotKeyItem.Assign(Item: TPersistent);
begin
if Item is TShenHotKeyItem then
begin
HotKey := TShenHotKeyItem(Item).HotKey;
ShiftState := TShenHotKeyItem(Item).ShiftState;
end else
inherited Assign(Item);
end;
{-----------------------------------------------------------------------------
Procedure: TShenHotKeyItem.GetDisplayName
Author: slq
Date: 08-三月-2002
Arguments: None
Result: string
Purpose: 设计期的显示名字
-----------------------------------------------------------------------------}
function TShenHotKeyItem.GetDisplayName: string;
procedure AddShift(const S: string);
begin
if Result <> '' then
Result := Result + ' + ';
Result := Result + S;
end;
begin
if HotKey = '' then
Result := inherited GetDisplayName
else
if Name <> '' then
Result := Name
else
begin
if ssAlt in ShiftState then
AddShift('Alt');
if ssCtrl in ShiftState then
AddShift('Ctrl');
if ssShift in ShiftState then
AddShift('Shift');
AddShift(HotKey);
end;
end;
{-----------------------------------------------------------------------------
Procedure: TShenHotKeyItem.GetNamePath
Author: slq
Date: 08-三月-2002
Arguments: None
Result: string
Purpose: 可能存在BUG,导致超过10个的时候出现小问题,
因为绝对不影响使用,也不会造成内存泄漏等,所以暂时不修正
-----------------------------------------------------------------------------}
function TShenHotKeyItem.GetNamePath: string;
function NameToSymbol(Name: string): string;
var i: Integer;
begin
Result := '';
for i := 1 to Length(Name) do
if Name in ['A'..'Z', 'a'..'z', '0'..'9'] then
Result := Result + Name;
end;
var S: string;
begin
if Collection <> nil then
begin
S := Name;
if (S = '') and (HotKey <> '') then
S := GetDisplayName;
S := NameToSymbol(S);
if S <> '' then
Result := Format('%s[%s]', [Collection.GetNamePath, S])
else
Result := Format('%s[%d]', [Collection.GetNamePath, Index]);
end else
Result := ClassName;
end;
{-----------------------------------------------------------------------------
Procedure: TShenHotKeyItem.GetHotKey
Author: slq
Date: 08-三月-2002
Arguments: None
Result: string
Purpose:
-----------------------------------------------------------------------------}
function TShenHotKeyItem.GetHotKey: string;
begin
Result := KeyLabels[FHotKey];
end;
{-----------------------------------------------------------------------------
Procedure: TShenHotKeyItem.SetHotKey
Author: slq
Date: 08-三月-2002
Arguments: Key: string
Result: None
Purpose:
-----------------------------------------------------------------------------}
procedure TShenHotKeyItem.SetHotKey(Key: string);
var i: Integer;
begin
i := 0;
while i < High(KeyLabels) do
begin
Inc(i);
if CompareText(Key, KeyLabels) = 0 then
Break;
end;
if i > High(KeyLabels) then
i := 0;
FHotKey := i;
if not (csDesigning in Manager.ComponentState) then
RegisterHotKey;
end;
{-----------------------------------------------------------------------------
Procedure: TShenHotKeyItem.SetShiftState
Author: slq
Date: 08-三月-2002
Arguments: State: TShenShiftState
Result: None
Purpose:
-----------------------------------------------------------------------------}
procedure TShenHotKeyItem.SetShiftState(State: TShenShiftState);
begin
FShiftState := State;
if not (csDesigning in Manager.ComponentState) then
RegisterHotKey;
end;
{-----------------------------------------------------------------------------
Procedure: TShenHotKeyItem.GetManager
Author: slq
Date: 08-三月-2002
Arguments: None
Result: TShenHotKeys
Purpose:
-----------------------------------------------------------------------------}
function TShenHotKeyItem.GetManager: TShenHotKeys;
begin
Result := THotKeyCollection(Collection).FOwner;
end;
{ PropEditors 属性编辑器 }
type
//
THotKeyProperty = class(TStringProperty)
public
function GetAttributes: TPropertyAttributes;
override;
procedure GetValues(Proc: TGetStrProc);
override;
end;
{-----------------------------------------------------------------------------
Procedure: THotKeyProperty.GetAttributes
Author: slq
Date: 08-三月-2002
Arguments: None
Result: TPropertyAttributes
Purpose:
-----------------------------------------------------------------------------}
function THotKeyProperty.GetAttributes: TPropertyAttributes;
begin
Result := [paValueList, paMultiSelect];
end;
{-----------------------------------------------------------------------------
Procedure: THotKeyProperty.GetValues
Author: slq
Date: 08-三月-2002
Arguments: Proc: TGetStrProc
Result: None
Purpose:
-----------------------------------------------------------------------------}
procedure THotKeyProperty.GetValues(Proc: TGetStrProc);
var i: Integer;
begin
for i := 1 to High(KeyLabels) do
Proc(KeyLabels);
end;
type
//
THotKeyManagerEditor = class(TComponentEditor)
protected
procedure GetPropEdit(Editor: TPropertyEditor);
public
end;
{-----------------------------------------------------------------------------
Procedure: THotKeyManagerEditor.GetPropEdit
Author: slq
Date: 08-三月-2002
Arguments: Editor: TPropertyEditor
Result: None
Purpose:
-----------------------------------------------------------------------------}
procedure THotKeyManagerEditor.GetPropEdit(Editor: TPropertyEditor);
begin
if Editor.GetName = 'HotKeys' then
Editor.Edit;
end;
{$IFDEF VER100} { Delphi 3/4 }
procedure THotKeyManagerEditor.Edit;
var L: TComponentList;
begin
L := TComponentList.Create;
try
L.Add(Component);
GetComponentProperties(L, [tkClass], Designer, GetPropEdit);
finally
L.Free;
end;
end;
{$ENDIF}
{$IFDEF VER130} { Delphi 5 }
procedure THotKeyManagerEditor.Edit;
var L: TDesignerSelectionList;
begin
L := TDesignerSelectionList.Create;
try
L.Add(Component);
GetComponentProperties(L, [tkClass], Designer, GetPropEdit);
finally
L.Free;
end;
end;
{$ENDIF}
{-----------------------------------------------------------------------------
Procedure: Register
Author: slq
Date: 08-三月-2002
Arguments: None
Result: None
Purpose: 注册
-----------------------------------------------------------------------------}
procedure Register;
begin
RegisterComponents('shen', [TShenHotKeys]);
RegisterPropertyEditor(TypeInfo(string), TShenHotKeyItem, 'HotKey',
THotKeyProperty);
RegisterComponentEditor(TShenHotKeys, THotKeyManagerEditor);
end;
end.