尽管高版本的Delphi已经提供强悍的手势功能，也非常好用，我还是没能用上，所以自己结合实际，参阅多个组件源码，改造了JvMouseGesture.pas单元，弄出一个实用的鼠标手势管理功能，记在这里，以免硬盘坏了，又要重来。
改造过的JvMouseGesture.pas单元代码：
unit JvMouseGesture; {$I jvcl.inc} interface uses {$IFDEF UNITVERSIONING} JclUnitVersioning, {$ENDIF UNITVERSIONING} SysUtils, Classes, Controls, Windows, Messages,Forms,Graphics, JvComponentBase; type { Description Defines, whether or not the hook will be activated automatically or not. } TJvActivationMode = (amAppStart, amManual); { Description Defines a complex gesture (two or more letters event) } TOnMouseGestureCustomInterpretation = procedure(Sender: TObject;const AGesture: string) of object; { Description This class implements the basic interpreter. It can be used to enhance single components, too. E.g., if you want to enable a grid with gesture feature. For this purpose you have to do 4 steps: 1) Fill the "OnMouseDown" event with code like <CODE> if Button = mbRight then JvMouseGesture1.StartMouseGesture(x,y); </CODE> 2) Fill the OnMouseMove event with something like <CODE> if JvMouseGesture1.TrailActive then JvMouseGesture1.TrailMouseGesture(x,y); </CODE> 3) Now fill the OnMouseUp event <CODE> if JvMouseGesture1.TrailActive then JvMouseGesture1.EndMouseGesture; </CODE> 4) Last but not least fill components OnJvMouseGestureCustomInterpretation XOR OnJvMouseGesture<xyz> event Note: If CustomInterpreation is filled the other events are not fired! See Also TJvMouseGestureHook } {$IFDEF RTL230_UP} [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)] {$ENDIF RTL230_UP} TJvMouseGesture = class(TJvComponent) private FForm: TForm; FActive: Boolean; FHided: Boolean; FTrailX: Integer; FTrailY: Integer; FTrailLength: Integer; FTrailActive: Boolean; FTrailStartTime: TDateTime; FdTolerance: Integer; FTrailLimit: Integer; FTrackWidth: Cardinal; FTrackColor: TColor; FDelay: Integer; FTrailInterval: Integer; FGrid: Integer; // tolerance for diagonal movement. See TrailMouseGesture FGridHalf: Integer; // half of grid, needed for performance FLastPushed: String; FGesture: string; FGestureList: TStringList; FLastWndProc: TWndMethod; FOnMouseGestureRight: TNotifyEvent; FOnMouseGestureLeft: TNotifyEvent; FOnMouseGestureUp: TNotifyEvent; FOnMouseGestureDown: TNotifyEvent; FOnMouseGestureLeftLowerEdge: TNotifyEvent; FOnMouseGestureRightUpperEdge: TNotifyEvent; FOnMouseGestureLeftUpperEdge: TNotifyEvent; FOnMouseGestureRightLowerEdge: TNotifyEvent; FOnMouseGestureCancelled: TNotifyEvent; FOnTrailingMouseGesture: TNotifyEvent; FOnMouseGestureCustomInterpretation: TOnMouseGestureCustomInterpretation; { Description Adds a detected sub gesture to gesture string } procedure AddGestureChar(AChar: String); procedure SetTrailLimit(const Value: Integer); procedure SetTrailInterval(const Value: Integer); procedure SetDelay(const Value: Integer); procedure SetGrid(const Value: Integer); procedure SetTrackColor(const Value: TColor); { Description Loads the known gestures for matching events Note: In this version only evaluation of simple mouse gestures are implemented } procedure LoadGestureTable; { Description Standard setter method for Active } procedure SetActive(const Value: Boolean); procedure Hide; // 内部函数，用来隐藏当前窗体(Internal function to hide the form) procedure AdjustSize; procedure WndProc(var Msg: TMessage); protected procedure DoMouseGestureRight; virtual; procedure DoMouseGestureLeft; virtual; procedure DoMouseGestureUp; virtual; procedure DoMouseGestureDown; virtual; procedure DoMouseGestureLeftLowerEdge; virtual; procedure DoMouseGestureRightUpperEdge; virtual; procedure DoMouseGestureLeftUpperEdge; virtual; procedure DoMouseGestureRightLowerEdge; virtual; procedure DoMouseGestureCancelled; virtual; procedure DoOnTrailingMouseGesture; virtual; function DoMouseGestureCustomInterpretation(const AGesture: string): Boolean; virtual; public { Description Standard constructor } constructor Create(AOwner: TComponent); override; { Description Standard destructor } destructor Destroy; override; { Description Starts the mouse gesture interpretation Parameters: AMouseX: X coordinate of mouse cursor AMouseY: Y coordinate of mouse cursor } procedure StartMouseGesture(AMouseX, AMouseY: Integer); { Description Continues the mouse gesture interpretation during mouse move Parameters: AMouseX: X coordinate of mouse cursor AMouseY: Y coordinate of mouse cursor } procedure TrailMouseGesture(AMouseX, AMouseY: Integer); { Description Ends the mouse gesture interpretation and fires an event if a gesture was found } procedure EndMouseGesture(AMouseX, AMouseY: Integer); { Description The actual length of trail (not of gesture string!!!) } procedure DrawGestureText(GText:String); property TrailLength: Integer read FTrailLength; { Description TRUE, if in detection, otherwise FALSE } property TrailActive: Boolean read FTrailActive; { Description The gesture string. For string content see description of unit. } property Gesture: string read FGesture; published { Description The maximum length of trail (not of gesture string!!!) Normally never been changed } property TrailLimit: Integer read FTrailLimit write SetTrailLimit; { Description Trail interval Normally never been changed } property TrailInterval: Integer read FTrailInterval write SetTrailInterval; { Description Grid size for detection Normally never been changed } property Grid: Integer read FGrid write SetGrid; { Description The maximum delay before cancelling a gesture Normally never been changed } property Delay: Integer read FDelay write SetDelay; { Description TRUE if component is active, otherwise FALSE } property Active: Boolean read FActive write SetActive; { Description Event for own evaluation of detected gesture. If this event is used all others will be ignored! } property TrackColor : TColor read FTrackColor write SetTrackColor default clRed; // 轨迹宽度，默认5px property TrackWidth: Cardinal read FTrackWidth write FTrackWidth default 5; property OnMouseGestureCustomInterpretation: TOnMouseGestureCustomInterpretation read FOnMouseGestureCustomInterpretation write FOnMouseGestureCustomInterpretation; { Description Event for a simple MOUSE UP gesture } property OnMouseGestureCancelled: TNotifyEvent read FOnMouseGestureCancelled write FOnMouseGestureCancelled; property OnMouseGestureUp: TNotifyEvent read FOnMouseGestureUp write FOnMouseGestureUp; { Description Event for a simple MOUSE DOWN gesture } property OnMouseGestureDown: TNotifyEvent read FOnMouseGestureDown write FOnMouseGestureDown; { Description Event for a simple MOUSE LEFT gesture } property OnMouseGestureLeft: TNotifyEvent read FOnMouseGestureLeft write FOnMouseGestureLeft; { Description Event for a simple MOUSE RIGHT gesture } property OnMouseGestureRight: TNotifyEvent read FOnMouseGestureRight write FOnMouseGestureRight; { Description Event for a simple diagonally MOUSE LEFT LOWER EDGE (point 1 in grid) gesture } property OnMouseGestureLeftLowerEdge: TNotifyEvent read FOnMouseGestureLeftLowerEdge write FOnMouseGestureLeftLowerEdge; { Description Event for a simple diagonally MOUSE RIGHT LOWER EDGE (point 3 in grid) gesture } property OnMouseGestureRightLowerEdge: TNotifyEvent read FOnMouseGestureRightLowerEdge write FOnMouseGestureRightLowerEdge; { Description Event for a simple diagonally MOUSE LEFT UPPER EDGE (point 7 in grid) gesture } property OnMouseGestureLeftUpperEdge: TNotifyEvent read FOnMouseGestureLeftUpperEdge write FOnMouseGestureLeftUpperEdge; { Description Event for a simple diagonally MOUSE RIGHT UPPER EDGE (point 9 in grid) gesture } property OnMouseGestureRightUpperEdge: TNotifyEvent read FOnMouseGestureRightUpperEdge write FOnMouseGestureRightUpperEdge; property OnTrailingMouseGesture: TNotifyEvent read FOnTrailingMouseGesture write FOnTrailingMouseGesture; end; { Description This class implements a application wide mouse hook for mouse gestures. Programmers get only one event for a detected mouse gesture: OnMouseGestureCustomInterpretation See Also TJvMouseGesture } {$IFDEF RTL230_UP} [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)] {$ENDIF RTL230_UP} TJvMouseGestureHook = class(TJvComponent) private FTrailLimit: Integer; FTrackWidth: Cardinal; FTrackColor: TColor; FDelay: Integer; FTrailInterval: Integer; FGrid: Integer; { Description True if a hook is installed } FHookInstalled: Boolean; { Description Field for hook handle } FCurrentHook: HHook; { Description Field for method pointer } FOnMouseGestureCustomInterpretation: TOnMouseGestureCustomInterpretation; { Description Field for active state of component } FOnCustomTrailingMouseGesture: TNotifyEvent; FActive: Boolean; { Description Field for mouse key } FMouseButton: TMouseButton; { Description Field for activation mode } FActivationMode: TJvActivationMode; { Description Standard setter method for evaluation of detected gesture } { Description Standard setter method for Active } procedure SetActive(const Value: Boolean); { Description Standard setter method for MouseButton } procedure SetMouseButton(const Value: TMouseButton); { Description Standard setter method for ActivationMode } procedure SetTrailLimit(const Value: Integer); procedure SetTrailInterval(const Value: Integer); procedure SetDelay(const Value: Integer); procedure SetGrid(const Value: Integer); procedure SetTrackColor(const Value: TColor); procedure SetTrackWidth(const Value: Cardinal); procedure SetActivationMode(const Value: TJvActivationMode); procedure SetMouseGestureCustomInterpretation(const Value: TOnMouseGestureCustomInterpretation); procedure SetTrailingMouseGesture(const Value: TNotifyEvent); function GetMouseGesture: TJvMouseGesture; protected { Description Create the hook. Maybe used in a later version as a new constructor to enable system wide hooks ... } procedure CreateForThreadOrSystem(AOwner: TComponent; ADwThreadID: Cardinal); function DoMouseGestureCustomInterpretation(const AGesture: string): Boolean; virtual; public { Description Standard constructor } constructor Create(AOwner: TComponent); override; { Description Standard destructor } destructor Destroy; override; { Description TRUE if hook was installed successfully } property HookInstalled: Boolean read FHookInstalled; //True if a hook is installed { Description handle of hook } property CurrentHook: HHook read FCurrentHook; //contains the handle of the currently installed hook property MouseGesture: TJvMouseGesture read GetMouseGesture; published property TrailLimit:Integer read FTrailLimit write SetTrailLimit; property TrackWidth:Cardinal read FTrackWidth write SetTrackWidth; property TrackColor:TColor read FTrackColor write SetTrackColor; property Delay:Integer read FDelay write SetDelay; property TrailInterval:Integer read FTrailInterval write SetTrailInterval; property Grid:Integer read FGrid write SetGrid; { Description TRUE if component is active, otherwise FALSE. Can be changed during runtime } property Active: Boolean read FActive write SetActive; { Description If property is set to <code>JvOnAppStart</code> then component will be activated on start of application, with <code>JvManually</code> you have to activate detection on your own } property ActivationMode: TJvActivationMode read FActivationMode write SetActivationMode; { Description Set the mouse key to be used for start/stop gesture See Also TMouseButton } property MouseButton: TMouseButton read FMouseButton write SetMouseButton default mbRight; { Description Set the event to be executed if a gesture will be detected } property OnMouseGestureCustomInterpretation: TOnMouseGestureCustomInterpretation read FOnMouseGestureCustomInterpretation write SetMouseGestureCustomInterpretation; property OnCustomTrailingMouseGesture: TNotifyEvent read FOnCustomTrailingMouseGesture write SetTrailingMouseGesture; end; { Description Hook call back function. DO NOT USE EXTERN! } function JvMouseGestureHook(Code: Integer; wParam: Word; lParam: Longword): Longword; stdcall; {$IFDEF UNITVERSIONING} const UnitVersioning: TUnitVersionInfo = ( RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvMouseGesture.pas $'; Revision: '$Revision: 13104 $'; Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $'; LogPath: 'JVCL un' ); {$ENDIF UNITVERSIONING} implementation uses JvResources, JvTypes; const JVMG_LEFT = 0; JVMG_RIGHT = 1; JVMG_UP = 2; JVMG_DOWN = 3; JVMG_LEFTUPPER = 4; JVMG_RIGHTUPPER = 5; JVMG_LEFTLOWER = 6; JVMG_RIGHTLOWER = 7; var { Description Object pointer to interpreter class used by hook } JvMouseGestureInterpreter: TJvMouseGesture; { Description Some global vars to be accessed by call back function ... } JvMouseGestureHookAlreadyInstalled: Boolean = False; //<combine JvMouseGestureHookAlreadyInstalled> JvMouseGestureHookActive: Boolean = False; //<combine JvMouseGestureHookAlreadyInstalled> JvMouseButtonDown: Cardinal = WM_RBUTTONDOWN; //<combine JvMouseGestureHookAlreadyInstalled> JvMouseButtonUp: Cardinal = WM_RBUTTONUP; JvCurrentHook: HHook = 0; //contains the handle of the currently installed hook //=== { TJvMouseGesture } ==================================================== constructor TJvMouseGesture.Create(AOwner: TComponent); begin inherited Create(AOwner); FGestureList := TStringList.Create; FGestureList.Sorted := True; FDelay := 500; FTrailLimit := 1000; FTrailInterval := 2; FGrid := 15; FTrackColor := clRed; FTrackWidth := 5; FGridHalf := FGrid div 2; FTrailActive := False; FdTolerance := 75; // tolerance for diagonal movement. see processCoordinates() begin FForm := TForm.Create(Self); FForm.TransparentColor := True; FForm.TransparentColorValue := clBlack; FForm.BorderStyle := bsNone; FForm.FormStyle := fsStayOnTop; FForm.DoubleBuffered := True; FForm.Color := clBlack; FLastWndProc := FForm.WindowProc; FForm.WindowProc := WndProc; AdjustSize; FForm.Canvas.Brush.Color := FForm.TransparentColorValue; FForm.Canvas.FillRect(FForm.ClientRect); ShowWindow(FForm.Handle,SW_SHOWNOACTIVATE); Hide; FHided := True; end; LoadGestureTable; FActive := not (csDesigning in ComponentState); end; destructor TJvMouseGesture.Destroy; begin FTrailActive := False; FreeAndNil(FGestureList); FForm.free; inherited Destroy; end; procedure TJvMouseGesture.LoadGestureTable; begin with FGestureList do begin AddObject('向左', TObject(JVMG_LEFT)); AddObject('向右', TObject(JVMG_RIGHT)); AddObject('向上', TObject(JVMG_UP)); AddObject('向下', TObject(JVMG_DOWN)); AddObject('向左斜下', TObject(JVMG_LEFTLOWER)); AddObject('向右斜下', TObject(JVMG_RIGHTLOWER)); AddObject('向左斜上', TObject(JVMG_LEFTUPPER)); AddObject('向右斜上', TObject(JVMG_RIGHTUPPER)); end; end; procedure TJvMouseGesture.SetActive(const Value: Boolean); begin if csDesigning in ComponentState then FActive := False else FActive := Value; end; procedure TJvMouseGesture.Hide; begin if not FHided then begin FForm.Canvas.Brush.Color := FForm.TransparentColorValue; FForm.Canvas.FillRect(FForm.ClientRect); FHided := True; end; end; procedure TJvMouseGesture.AdjustSize; begin if not (csDesigning in ComponentState) then FForm.SetBounds(Screen.DesktopLeft, Screen.DesktopTop, Screen.DesktopWidth, Screen.DesktopWidth) else FForm.SetBounds(Screen.DesktopLeft, Screen.DesktopTop, 0, 0); end; procedure TJvMouseGesture.WndProc(var Msg: TMessage); begin if Msg.Msg = WM_NCHITTEST then Msg.Result := HTTRANSPARENT else if Msg.Msg = (WM_APP + 1) then AdjustSize else if Msg.Msg = (WM_APP + 2) then begin end else begin FLastWndProc(Msg); if Msg.Msg = WM_DISPLAYCHANGE then PostMessage(FForm.Handle, WM_APP + 1, 0, 0) else if Msg.Msg = WM_WINDOWPOSCHANGED then //保持窗口在最前，以保证能够覆盖绘制轨迹， PostMessage(FForm.Handle, WM_APP + 2, 0, 0); end; end; procedure TJvMouseGesture.SetTrailLimit(const Value: Integer); begin FTrailLimit := Value; if (FTrailLimit < 100) or (FTrailLimit > 10000) then FTrailLimit := 1000; end; procedure TJvMouseGesture.SetTrailInterval(const Value: Integer); begin FTrailInterval := Value; if (FTrailInterval < 1) or (FTrailInterval > 100) then FTrailInterval := 2; end; procedure TJvMouseGesture.SetDelay(const Value: Integer); begin FDelay := Value; if FDelay < 500 then FDelay := 500; end; procedure TJvMouseGesture.SetGrid(const Value: Integer); begin FGrid := Value; if (FGrid < 10) or (FGrid > 500) then FGrid := 15; FGridHalf := FGrid div 2; end; procedure TJvMouseGesture.SetTrackColor(const Value: TColor); begin if FTrackColor <> Value then begin FTrackColor := Value; if FTrackColor = clBlack then FForm.Color := clWhite else FForm.Color := clBlack; FForm.TransparentColorValue := FForm.Color; end; end; procedure TJvMouseGesture.AddGestureChar(AChar: String); begin if AChar <> FLastPushed then begin FGesture := FGesture +'→'+ AChar; FLastPushed := AChar; end; end; procedure TJvMouseGesture.StartMouseGesture(AMouseX, AMouseY: Integer); begin if not FActive then Exit; FForm.Show; FForm.BringToFront; FForm.Canvas.MoveTo(AMouseX, AMouseY); FLastPushed := #0; FGesture := ''; FTrailActive := True; FTrailLength := 0; FTrailX := AMouseX; FTrailY := AMouseY; FTrailStartTime := now; FHided:=False; end; procedure TJvMouseGesture.TrailMouseGesture(AMouseX, AMouseY: Integer); var locX: Integer; locY: Integer; x_dir: Integer; y_dir: Integer; tolerancePercent: Double; x_divide_y: Double; y_divide_x: Double; function InBetween(AValue, AMin, AMax: Double): Boolean; begin Result := (AValue >= AMin) and (AValue <= AMax); end; begin if not FActive then Exit; if (not FTrailActive) or (FTrailLength > FTrailLimit) then begin FTrailActive := False; Exit; end; try x_dir := AMouseX - FTrailX; y_dir := AMouseY - FTrailY; locX := abs(x_dir); locY := abs(y_dir); // process each half-grid if (locX >= FGridHalf) or (locY >= FGridHalf) then begin // diagonal movement: // dTolerance = 75 means that a movement is recognized as diagonal when // x/y or y/x is between 0.25 and 1 if (GetTopWindow(0) <> FForm.Handle) and Application.Active then FForm.BringToFront; FForm.Canvas.Pen.Color := FTrackColor; FForm.Canvas.Pen.Width := FTrackWidth; FForm.Canvas.LineTo(AMouseX, AMouseY); tolerancePercent := 1 - FdTolerance / 100; if locY <> 0 then x_divide_y := locX / locY else x_divide_y := 0; if locX <> 0 then y_divide_x := locY / locX else y_divide_x := 0; if (FdTolerance <> 0) and (InBetween(x_divide_y, tolerancePercent, 1) or InBetween(y_divide_x, tolerancePercent, 1)) then begin if (x_dir < -9) and (y_dir > 9) then begin AddGestureChar('向左斜下'); end else begin if (x_dir > 9) and (y_dir > 9) then AddGestureChar('向右斜下') else begin if (x_dir < -9) and (y_dir < -9) then AddGestureChar('向左斜上') else begin if (x_dir > 9) and (y_dir < -9) then AddGestureChar('向右斜上'); end; end; end; end // of diaognal else begin // horizontal movement: if locX > locY then begin if x_dir > 0 then AddGestureChar('向右') else begin if x_dir < 0 then AddGestureChar('向左'); end; end else begin // vertical movement: if locX < locY then begin if y_dir > 0 then AddGestureChar('向下') else begin if y_dir < 0 then AddGestureChar('向上'); end; end; end; end; end; // of half grid finally FTrailX := AMouseX; FTrailY := AMouseY; end; DoOnTrailingMouseGesture; end; procedure TJvMouseGesture.DrawGestureText(GText:String); begin FForm.Canvas.TextOut(300,300,GText); end; procedure TJvMouseGesture.EndMouseGesture(AMouseX, AMouseY: Integer); var Index: Integer; begin Hide; if not FActive then Exit; FTrailActive := False; if FGesture = '' then begin DoMouseGestureCancelled; Exit; end; // check for custom interpretation first if DoMouseGestureCustomInterpretation(FGesture) then Exit else Hide; // if no custom interpretation is implemented we chaeck for known gestures // and matching events // CASE indexes are stored sequence independent. So we have to find gesture // first and get CASE INDEX stored as TObject in Object property. It's a // simple trick, but works fine ... Index := FGestureList.IndexOf(FGesture); if Index > -1 then Index := Integer(FGestureList.Objects[Index]); case Index of JVMG_LEFT: begin DoMouseGestureLeft; end; JVMG_RIGHT: begin DoMouseGestureRight; end; JVMG_UP: begin DoMouseGestureUp; end; JVMG_DOWN: begin DoMouseGestureDown; end; JVMG_LEFTLOWER: begin DoMouseGestureLeftLowerEdge; end; JVMG_RIGHTLOWER: begin DoMouseGestureRightLowerEdge; end; JVMG_LEFTUPPER: begin DoMouseGestureLeftUpperEdge; end; JVMG_RIGHTUPPER: begin DoMouseGestureRightUpperEdge; end; end; end; procedure TJvMouseGesture.DoMouseGestureCancelled; begin if Assigned(FOnMouseGestureCancelled) then FOnMouseGestureCancelled(Self); end; procedure TJvMouseGesture.DoOnTrailingMouseGesture; begin if Assigned(FOnTrailingMouseGesture) then FOnTrailingMouseGesture(Self); end; function TJvMouseGesture.DoMouseGestureCustomInterpretation(const AGesture: string): Boolean; begin Result := Assigned(FOnMouseGestureCustomInterpretation); if Result then begin FOnMouseGestureCustomInterpretation(Self,FGesture); end; Hide; end; procedure TJvMouseGesture.DoMouseGestureDown; begin if Assigned(FOnMouseGestureDown) then FOnMouseGestureDown(Self); end; procedure TJvMouseGesture.DoMouseGestureLeft; begin if Assigned(FOnMouseGestureLeft) then FOnMouseGestureLeft(Self); end; procedure TJvMouseGesture.DoMouseGestureLeftLowerEdge; begin if Assigned(FOnMouseGestureLeftLowerEdge) then FOnMouseGestureLeftLowerEdge(Self); end; procedure TJvMouseGesture.DoMouseGestureLeftUpperEdge; begin if Assigned(FOnMouseGestureLeftUpperEdge) then FOnMouseGestureLeftUpperEdge(Self); end; procedure TJvMouseGesture.DoMouseGestureRight; begin if Assigned(FOnMouseGestureRight) then FOnMouseGestureRight(Self); end; procedure TJvMouseGesture.DoMouseGestureRightLowerEdge; begin if Assigned(FOnMouseGestureRightLowerEdge) then FOnMouseGestureRightLowerEdge(Self); end; procedure TJvMouseGesture.DoMouseGestureRightUpperEdge; begin if Assigned(FOnMouseGestureRightUpperEdge) then FOnMouseGestureRightUpperEdge(Self); end; procedure TJvMouseGesture.DoMouseGestureUp; begin if Assigned(FOnMouseGestureUp) then FOnMouseGestureUp(Self); end; //=== { TJvMouseGestureHook } ================================================ constructor TJvMouseGestureHook.Create(AOwner: TComponent); begin inherited Create(AOwner); FDelay := 500; FTrailLimit := 1000; FTrailInterval := 2; FGrid := 15; FTrackColor := clRed; FTrackWidth := 5; CreateForThreadOrSystem(AOwner, MainThreadID); // hook for complete application JvMouseGestureInterpreter.Delay:=FDelay; JvMouseGestureInterpreter.Grid:=FGrid; JvMouseGestureInterpreter.TrackWidth:=FTrackWidth; JvMouseGestureInterpreter.TrackColor:=FTrackColor; JvMouseGestureInterpreter.TrailLimit:=FTrailLimit; JvMouseGestureInterpreter.TrailInterval:=FTrailInterval; end; destructor TJvMouseGestureHook.Destroy; begin FreeAndNil(JvMouseGestureInterpreter); if JvMouseGestureHookAlreadyInstalled then JvMouseGestureHookAlreadyInstalled := UnhookWindowsHookEx(JvCurrentHook); inherited Destroy; end; procedure TJvMouseGestureHook.SetTrailLimit(const Value: Integer); begin FTrailLimit := Value; if (FTrailLimit < 100) or (FTrailLimit > 10000) then FTrailLimit := 1000; JvMouseGestureInterpreter.TrailLimit:=FTrailLimit; end; procedure TJvMouseGestureHook.SetTrailInterval(const Value: Integer); begin FTrailInterval := Value; if (FTrailInterval < 1) or (FTrailInterval > 100) then FTrailInterval := 2; JvMouseGestureInterpreter.TrailInterval:=FTrailInterval; end; procedure TJvMouseGestureHook.SetDelay(const Value: Integer); begin FDelay := Value; if FDelay < 500 then FDelay := 500; JvMouseGestureInterpreter.Delay:=FDelay; end; procedure TJvMouseGestureHook.SetGrid(const Value: Integer); begin FGrid := Value; if (FGrid < 10) or (FGrid > 500) then FGrid := 15; JvMouseGestureInterpreter.Grid:=FGrid; end; procedure TJvMouseGestureHook.SetTrackColor(const Value: TColor); begin if FTrackColor <> Value then begin FTrackColor := Value; JvMouseGestureInterpreter.TrackColor:=FTrackColor; if FTrackColor = clBlack then JvMouseGestureInterpreter.FForm.Color := clWhite else JvMouseGestureInterpreter.FForm.Color := clBlack; JvMouseGestureInterpreter.FForm.TransparentColorValue := JvMouseGestureInterpreter.FForm.Color; end; end; procedure TJvMouseGestureHook.SetTrackWidth(const Value: Cardinal); begin FTrackWidth:=Value; JvMouseGestureInterpreter.TrackWidth:=FTrackWidth; end; procedure TJvMouseGestureHook.CreateForThreadOrSystem(AOwner: TComponent; ADwThreadID: Cardinal); begin if JvMouseGestureHookAlreadyInstalled then raise EJVCLException.CreateRes(@RsECannotHookTwice); JvMouseGestureInterpreter := TJvMouseGesture.Create(nil); FMouseButton := mbRight; if csDesigning in ComponentState then begin FActive := False; Exit; end; FActive := FActivationMode = amAppStart; //install hook FCurrentHook := SetWindowsHookEx(WH_MOUSE, @JvMouseGestureHook, 0, ADwThreadID); //return True if it worked (read only for user). User should never see a //global var like MouseGestureHookAlreadyInstalled FHookInstalled := FCurrentHook <> 0; // global remember, internal use only JvMouseGestureHookAlreadyInstalled := FHookInstalled; JvCurrentHook := FCurrentHook; // map event if Assigned(FOnMouseGestureCustomInterpretation) then JvMouseGestureInterpreter.OnMouseGestureCustomInterpretation := FOnMouseGestureCustomInterpretation else JvMouseGestureInterpreter.OnMouseGestureCustomInterpretation := nil; end; function TJvMouseGestureHook.DoMouseGestureCustomInterpretation(const AGesture: string): Boolean; begin Result := Assigned(FOnMouseGestureCustomInterpretation); if Result then FOnMouseGestureCustomInterpretation(Self, AGesture); end; procedure TJvMouseGestureHook.SetActivationMode(const Value: TJvActivationMode); begin FActivationMode := Value; end; procedure TJvMouseGestureHook.SetActive(const Value: Boolean); begin if csDesigning in ComponentState then FActive := False else FActive := Value; JvMouseGestureHookActive := FActive; end; procedure TJvMouseGestureHook.SetMouseButton(const Value: TMouseButton); begin FMouseButton := Value; case Value of mbLeft: begin JvMouseButtonDown := WM_LBUTTONDOWN; JvMouseButtonUp := WM_LBUTTONUP; end; mbMiddle: begin JvMouseButtonDown := WM_MBUTTONDOWN; JvMouseButtonUp := WM_MBUTTONUP; end; mbRight: begin JvMouseButtonDown := WM_RBUTTONDOWN; JvMouseButtonUp := WM_RBUTTONUP; end; end; end; procedure TJvMouseGestureHook.SetMouseGestureCustomInterpretation( const Value: TOnMouseGestureCustomInterpretation); begin FOnMouseGestureCustomInterpretation := Value; if Assigned(JvMouseGestureInterpreter) then JvMouseGestureInterpreter.OnMouseGestureCustomInterpretation := Value; end; procedure TJvMouseGestureHook.SetTrailingMouseGesture(const Value: TNotifyEvent); begin FOnCustomTrailingMouseGesture:=Value; if Assigned(JvMouseGestureInterpreter) then JvMouseGestureInterpreter.OnTrailingMouseGesture := Value; end; function TJvMouseGestureHook.GetMouseGesture: TJvMouseGesture; begin Result := JvMouseGestureInterpreter; end; //============================================================================ function JvMouseGestureHook(Code: Integer; wParam: Word; lParam: Longword): Longword; stdcall; var locY: Integer; locX: Integer; begin if (Code >= 0) and (JvMouseGestureHookActive) then begin with PMouseHookStruct(lParam)^ do begin locX := pt.X; locY := pt.Y; end; if wParam = WM_MOUSEMOVE then begin JvMouseGestureInterpreter.TrailMouseGesture(locX, locY); end; if wParam = JvMouseButtonDown then begin JvMouseGestureInterpreter.StartMouseGesture(locX, locY); end else if wParam = JvMouseButtonUp then begin JvMouseGestureInterpreter.EndMouseGesture(locX, locY); end; end; Result := CallNextHookEx(JvCurrentHook, Code, wParam, lParam); end; {$IFDEF UNITVERSIONING} initialization RegisterUnitVersion(HInstance, UnitVersioning); finalization UnregisterUnitVersion(HInstance); {$ENDIF UNITVERSIONING} end.
增加了几个东西：
FForm: TForm：用于绘制显示手势规矩
FTrackWidth: Cardinal;手势轨迹宽度
FTrackColor: TColor;手势轨迹颜色
此外主要改造了以下几个过程、函数
constructor TJvMouseGesture.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FGestureList := TStringList.Create;
FGestureList.Sorted := True;
FDelay := 500;
FTrailLimit := 1000;
FTrailInterval := 2;
FGrid := 15;
FTrackColor := clRed;
FTrackWidth := 5;
FGridHalf := FGrid div 2;
FTrailActive := False;
FdTolerance := 75; // tolerance for diagonal movement. see processCoordinates()
begin
FForm := TForm.Create(Self);
FForm.TransparentColor := True;
FForm.TransparentColorValue := clBlack;
FForm.BorderStyle := bsNone;
FForm.FormStyle := fsStayOnTop;
FForm.DoubleBuffered := True;
FForm.Color := clBlack;
FLastWndProc := FForm.WindowProc;
FForm.WindowProc := WndProc;
AdjustSize;
FForm.Canvas.Brush.Color := FForm.TransparentColorValue;
FForm.Canvas.FillRect(FForm.ClientRect);
ShowWindow(FForm.Handle,SW_SHOWNOACTIVATE);
Hide;
FHided := True;
end;
LoadGestureTable;
FActive := not (csDesigning in ComponentState);
end;
procedure TJvMouseGesture.LoadGestureTable; begin with FGestureList do begin AddObject('向左', TObject(JVMG_LEFT)); AddObject('向右', TObject(JVMG_RIGHT)); AddObject('向上', TObject(JVMG_UP)); AddObject('向下', TObject(JVMG_DOWN)); AddObject('向左斜下', TObject(JVMG_LEFTLOWER)); AddObject('向右斜下', TObject(JVMG_RIGHTLOWER)); AddObject('向左斜上', TObject(JVMG_LEFTUPPER)); AddObject('向右斜上', TObject(JVMG_RIGHTUPPER)); end; end;
此处替换了原来的手势名称，改为中文，这样用户才看得懂
procedure TJvMouseGesture.StartMouseGesture(AMouseX, AMouseY: Integer); begin if not FActive then Exit; FForm.Show; FForm.BringToFront; FForm.Canvas.MoveTo(AMouseX, AMouseY); FLastPushed := #0; FGesture := ''; FTrailActive := True; FTrailLength := 0; FTrailX := AMouseX; FTrailY := AMouseY; FTrailStartTime := now; FHided:=False; end; procedure TJvMouseGesture.TrailMouseGesture(AMouseX, AMouseY: Integer); var locX: Integer; locY: Integer; x_dir: Integer; y_dir: Integer; tolerancePercent: Double; x_divide_y: Double; y_divide_x: Double; function InBetween(AValue, AMin, AMax: Double): Boolean; begin Result := (AValue >= AMin) and (AValue <= AMax); end; begin if not FActive then Exit; if (not FTrailActive) or (FTrailLength > FTrailLimit) then begin FTrailActive := False; Exit; end; try x_dir := AMouseX - FTrailX; y_dir := AMouseY - FTrailY; locX := abs(x_dir); locY := abs(y_dir); // process each half-grid if (locX >= FGridHalf) or (locY >= FGridHalf) then begin // diagonal movement: // dTolerance = 75 means that a movement is recognized as diagonal when // x/y or y/x is between 0.25 and 1 if (GetTopWindow(0) <> FForm.Handle) and Application.Active then FForm.BringToFront; FForm.Canvas.Pen.Color := FTrackColor; FForm.Canvas.Pen.Width := FTrackWidth; FForm.Canvas.LineTo(AMouseX, AMouseY); tolerancePercent := 1 - FdTolerance / 100; if locY <> 0 then x_divide_y := locX / locY else x_divide_y := 0; if locX <> 0 then y_divide_x := locY / locX else y_divide_x := 0; if (FdTolerance <> 0) and (InBetween(x_divide_y, tolerancePercent, 1) or InBetween(y_divide_x, tolerancePercent, 1)) then begin if (x_dir < -9) and (y_dir > 9) then begin AddGestureChar('向左斜下'); end else begin if (x_dir > 9) and (y_dir > 9) then AddGestureChar('向右斜下') else begin if (x_dir < -9) and (y_dir < -9) then AddGestureChar('向左斜上') else begin if (x_dir > 9) and (y_dir < -9) then AddGestureChar('向右斜上'); end; end; end; end // of diaognal else begin // horizontal movement: if locX > locY then begin if x_dir > 0 then AddGestureChar('向右') else begin if x_dir < 0 then AddGestureChar('向左'); end; end else begin // vertical movement: if locX < locY then begin if y_dir > 0 then AddGestureChar('向下') else begin if y_dir < 0 then AddGestureChar('向上'); end; end; end; end; end; // of half grid finally FTrailX := AMouseX; FTrailY := AMouseY; end; DoOnTrailingMouseGesture; end;
这个地方也改造了
此外还定义了一个新的组件，以方便用户自定义鼠标手势，其代码如下：
unit UWSGestureREC; interface uses Windows,SysUtils, Messages ,Classes, Controls,Graphics,GraphUtil, Generics.Collections,Math,Dialogs; type TGesturePoints = TList<TPoint>; TOnMouseGestureCustomInterpretation = procedure(Sender: TObject;const AGesture: string) of object; TCustomUWSGestureRecord = class(TCustomControl) private { Private declarations } FGesture:string; FGestureLineColor: TColor; FGesturePointColor: TColor; FLastDrawnPoint: Integer; FPoints: TGesturePointArray; FRecordedPoints: TGesturePoints; FRecording: Boolean; FPlaying:Boolean ; FCaption: string; FLastPushed: String; FTrailX: Integer; FTrailY: Integer; FTrailLength: Integer; FTrailActive: Boolean; FTrailStartTime: TDateTime; FdTolerance: Integer; FTrailLimit: Integer; FGridHalf: Integer; FStandardGestures:TStringList; FBasicGestures:TStringList; FGestureFileName:string; FOnMouseGestureCustomInterpretation: TOnMouseGestureCustomInterpretation; FOnTrailingGesture: TOnMouseGestureCustomInterpretation; procedure AddGesturePoint(const LastPoint, NextPoint: TPoint); function PointsToArray(Source: TGesturePoints): TGesturePointArray; procedure SetCaption(const Value: string); procedure SetGestureLineColor(const Value: TColor); procedure SetGesturePointColor(const Value: TColor); procedure ShortGesture; protected { Protected declarations } procedure DrawPoint(const Point: TPoint); virtual; 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; procedure WndProc(var Message: TMessage); override; function DoMouseGestureCustomInterpretation(const AGesture: string): Boolean; virtual; function DoTrailingGesture(const AGesture: string): Boolean; virtual; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; function NormalizePoints(const Points: array of TPoint): TGesturePointArray; procedure AddGestureChar(AChar: String); procedure StartMouseGesture(AMouseX, AMouseY: Integer); procedure TrailMouseGesture(AMouseX, AMouseY: Integer); procedure EndMouseGesture(AMouseX, AMouseY: Integer); procedure Play; procedure PlayStandard(aGesture:String); procedure ReRestSize; procedure PlayFromFile(aGestureFile:String); procedure SaveGesturePointtoFile(aGPFile:String); function IsStandardGesture(aGesture:String):Boolean; function GesturetoGestureFileName(aGesture:String):string; procedure ExpoertStandardGesture2List(Items:TStrings); property RecordedPoints: TGesturePoints read FRecordedPoints write FRecordedPoints; property Caption: string read FCaption write SetCaption; property Gesture:string read FGesture write FGesture; property GestureLineColor: TColor read FGestureLineColor write SetGestureLineColor default clBlue; property GesturePointColor: TColor read FGesturePointColor write SetGesturePointColor default clBlue; property GestureFileName:string read FGestureFileName; property OnMouseGestureCustomInterpretation: TOnMouseGestureCustomInterpretation read FOnMouseGestureCustomInterpretation write FOnMouseGestureCustomInterpretation; property OnTrailingGesture: TOnMouseGestureCustomInterpretation read FOnTrailingGesture write FOnTrailingGesture; property StandardGestures:TStringList read FStandardGestures; published { Published declarations } end; TUWSGestureRecord = class(TCustomUWSGestureRecord) private { Private declarations } protected { Protected declarations } public { Public declarations } published { Published declarations } property Align; property Anchors; property BevelEdges; property BevelInner; property BevelOuter; property BevelKind default bkNone; property BevelWidth; property BiDiMode; property Caption; property Color; property Constraints; property Ctl3D; property DoubleBuffered default True; property DragCursor; property DragKind; property DragMode; property Enabled; property Font; property GestureLineColor; property GesturePointColor; property Height default 200; property ParentBiDiMode; property ParentColor; property ParentDoubleBuffered default False; property ParentFont; property ParentShowHint; property PopupMenu; property ShowHint; property Visible; property Width default 200; property OnClick; property OnContextPopup; property OnEndDock; property OnEndDrag; property OnGesture; property OnDragDrop; property OnDragOver; property OnMouseActivate; property OnMouseDown; property OnMouseEnter; property OnMouseLeave; property OnMouseMove; property OnMouseUp; property OnResize; property OnStartDock; property OnStartDrag; property OnMouseGestureCustomInterpretation; property OnTrailingGesture; end; procedure Register; implementation procedure Register; begin RegisterComponents('uws Used', [TUWSGestureRecord]); end; constructor TCustomUWSGestureRecord.Create(AOwner: TComponent); begin inherited; AlignWithMargins:=True; Margins.Top:=7; Margins.Bottom:=7; Margins.Left:=7; Margins.Right:=7; FGesture :=''; FGestureLineColor := clBlue; FGesturePointColor := clBlue; FRecordedPoints := TGesturePoints.Create; FTrailLimit := 1000; FGridHalf := 8; FTrailActive := False; FdTolerance := 75; // tol FRecording := False; Height := 200; Width := 200; ControlStyle := ControlStyle - [csGestures]; DoubleBuffered := True; ParentDoubleBuffered := False; FStandardGestures:=TStringList.Create; FStandardGestures.Add('→向右'); FStandardGestures.Add('→向左'); FStandardGestures.Add('→向上'); FStandardGestures.Add('→向下'); FStandardGestures.Add('→向右斜上'); FStandardGestures.Add('→向右斜下'); FStandardGestures.Add('→向左斜上'); FStandardGestures.Add('→向左斜下'); FStandardGestures.Add('→向下→向右'); FStandardGestures.Add('→向下→向左'); FStandardGestures.Add('→向上→向右'); FStandardGestures.Add('→向上→向左'); FStandardGestures.Add('→向右→向下'); FStandardGestures.Add('→向左→向下'); FStandardGestures.Add('→向右→向上'); FStandardGestures.Add('→向左→向上'); FStandardGestures.Add('→向右→向左'); FStandardGestures.Add('→向左→向右'); FStandardGestures.Add('→向下→向上'); FStandardGestures.Add('→向上→向下'); FBasicGestures:=TStringList.Create; FBasicGestures.Add('向右'); FBasicGestures.Add('向左'); FBasicGestures.Add('向上'); FBasicGestures.Add('向下'); FBasicGestures.Add('向右斜上'); FBasicGestures.Add('向右斜下'); FBasicGestures.Add('向左斜上'); FBasicGestures.Add('向左斜下'); end; destructor TCustomUWSGestureRecord.Destroy; begin FreeAndNil(FRecordedPoints); FreeAndNil(FStandardGestures); FreeAndNil(FBasicGestures); inherited; end; procedure TCustomUWSGestureRecord.ReRestSize; begin if Height<200 then Height:=200; if Width<200 then Width:=200; if Height<>width then Height:=Width ; end; procedure TCustomUWSGestureRecord.Play; var I:Integer; LRect: TRect; begin FPlaying:=True; LRect := ClientRect; Canvas.Brush.Color := Color; Canvas.FillRect(LRect); if FRecordedPoints.Count>0 then begin Canvas.MoveTo(FRecordedPoints[0].X, FRecordedPoints[0].Y); for I := 0 to FRecordedPoints.Count - 1 do begin DrawPoint(FRecordedPoints[I]); Sleep(10); end; end; FPlaying:=False; end; procedure TCustomUWSGestureRecord.PlayStandard(aGesture:String); var I,K,CC:Integer; LRect: TRect; begin if aGesture='' then Exit; FPlaying:=True; CC:=Min(Width,Height); LRect := ClientRect; Canvas.Brush.Color := Color; Canvas.FillRect(LRect); if aGesture='→向右' then begin Canvas.MoveTo(20, Height div 2); for I := 20 to Width-20 do begin DrawPoint(Point(I,Height div 2)); Sleep(1); end; end else if aGesture='→向左' then begin Canvas.MoveTo(Width-20, Height div 2); for I := Width-20 downto 20 do begin DrawPoint(Point(I,Height div 2)); Sleep(1); end; end else if aGesture='→向下' then begin Canvas.MoveTo(Width div 2, 20); for I := 20 to Height-20 do begin DrawPoint(Point(Width div 2,I)); Sleep(1); end; end else if aGesture='→向上' then begin Canvas.MoveTo(Width div 2, Height-20); for I := Height-20 downto 20 do begin DrawPoint(Point(Width div 2,I)); Sleep(1); end; end else if aGesture='→向右斜下' then begin Canvas.MoveTo(20, 20); for I := 20 to CC-20 do begin DrawPoint(Point(I,I)); Sleep(1); end; end else if aGesture='→向右斜上' then begin Canvas.MoveTo(20, Height-20); for I := 20 to CC-20 do begin DrawPoint(Point(I,Height-I)); Sleep(1); end; end else if aGesture='→向左斜下' then begin Canvas.MoveTo(Width-20, 20); for I := 20 to CC-20 do begin DrawPoint(Point(Width-I,I)); Sleep(1); end; end else if aGesture='→向左斜上' then begin Canvas.MoveTo(Width-20, Height-20); for I := 20 to CC-20 do begin DrawPoint(Point(Width-I,Height-I)); Sleep(1); end; end else if aGesture='→向下→向右' then begin Canvas.MoveTo(60, 60); for I := 60 to CC-60 do begin DrawPoint(Point(60,I)); Sleep(1); end; for I := 60 to CC-60 do begin DrawPoint(Point(I,Height-60)); Sleep(1); end; end else if aGesture='→向下→向左' then begin Canvas.MoveTo(width-60,60); for I := 60 to CC-60 do begin DrawPoint(Point(width-60,I)); Sleep(1); end; for I := 60 to CC-60 do begin DrawPoint(Point(width-I,Height-60)); Sleep(1); end; end else if aGesture='→向上→向右' then begin Canvas.MoveTo(60,Height-60); for I := 60 to CC-60 do begin DrawPoint(Point(60,Height-I)); Sleep(1); end; for I := 60 to CC-60 do begin DrawPoint(Point(I,60)); Sleep(1); end; end else if aGesture='→向上→向左' then begin Canvas.MoveTo(Width-60,Height-60); for I := 60 to CC-60 do begin DrawPoint(Point(Width-60,Height-I)); Sleep(1); end; for I := 60 to CC-60 do begin DrawPoint(Point(Width-I,60)); Sleep(1); end; end else if aGesture='→向左→向上' then begin Canvas.MoveTo(Width-60,Height-60); for I := 60 to CC-60 do begin DrawPoint(Point(Width-I,Height-60)); Sleep(1); end; for I := 60 to CC-60 do begin DrawPoint(Point(60,Height-I)); Sleep(1); end; end else if aGesture='→向左→向下' then begin Canvas.MoveTo(Width-60,60); for I := 60 to CC-60 do begin DrawPoint(Point(Width-I,60)); Sleep(1); end; for I := 60 to CC-60 do begin DrawPoint(Point(60,I)); Sleep(1); end; end else if aGesture='→向右→向上' then begin Canvas.MoveTo(60,Height-60); for I := 60 to CC-60 do begin DrawPoint(Point(I,Height-60)); Sleep(1); end; for I := 60 to CC-60 do begin DrawPoint(Point(Width-60,Height-I)); Sleep(1); end; end else if aGesture='→向右→向下' then begin Canvas.MoveTo(60,60); for I := 60 to CC-60 do begin DrawPoint(Point(I,60)); Sleep(1); end; for I := 60 to CC-60 do begin DrawPoint(Point(Width-60,I)); Sleep(1); end; end else if aGesture='→向右→向左' then begin Canvas.MoveTo(60,Height div 2); for I := 60 to CC-60 do begin DrawPoint(Point(I,Height div 2)); Sleep(1); end; for I := 60 to CC-60 do begin DrawPoint(Point(Width-I,Height div 2)); Sleep(1); end; end else if aGesture='→向左→向右' then begin Canvas.MoveTo(Width-60,Height div 2); for I := 60 to CC-60 do begin DrawPoint(Point(Width-I,Height div 2)); Sleep(1); end; for I := 60 to CC-60 do begin DrawPoint(Point(I,Height div 2)); Sleep(1); end; end else if aGesture='→向下→向上' then begin Canvas.MoveTo(Width div 2,60); for I := 60 to CC-60 do begin DrawPoint(Point(Width div 2,I)); Sleep(1); end; for I := 60 to CC-60 do begin DrawPoint(Point(Width div 2,Height-I)); Sleep(1); end; end else if aGesture='→向上→向下' then begin Canvas.MoveTo(Width div 2,Height-60); for I := 60 to CC-60 do begin DrawPoint(Point(Width div 2,Height-I)); Sleep(1); end; for I := 60 to CC-60 do begin DrawPoint(Point(Width div 2,I)); Sleep(1); end; end; FPlaying:=False; end; function TCustomUWSGestureRecord.IsStandardGesture(aGesture:String):Boolean; begin Result:=False ; if aGesture='' then Exit; Result:=(FStandardGestures.IndexOf(aGesture)<>-1); end; function TCustomUWSGestureRecord.GesturetoGestureFileName(aGesture:String):string; var Temp:TStringList; I,ID:Integer; begin Result:=''; if aGesture='' then Exit; Temp:=TStringList.Create; try Temp.Delimiter:='→'; Temp.DelimitedText:=aGesture; for I := 0 to Temp.Count-1 do begin if Temp[I]<>'' then begin ID:=FBasicGestures.IndexOf(Temp[I]); Result:=Result+InttoStr(ID); end; end; finally Temp.Free; end; Result:=Result+'.GPS'; end; procedure TCustomUWSGestureRecord.ExpoertStandardGesture2List(Items:TStrings); begin Items.Assign(FStandardGestures); end; procedure TCustomUWSGestureRecord.SaveGesturePointtoFile(aGPFile:String); var I:Integer; Temp:TStringList; begin if aGPFile='' then aGPFile:='123.GPS'; if FRecordedPoints.Count<1 then Exit; Temp:=TStringList.Create ; try for I := 0 to FRecordedPoints.Count-1 do begin Temp.Add(Format('X%d=%d',[I,FRecordedPoints[I].X])); Temp.Add(Format('Y%d=%d',[I,FRecordedPoints[I].Y])); end; Temp.SaveToFile(aGPFile); finally Temp.Free; end; end; procedure TCustomUWSGestureRecord.PlayFromFile(aGestureFile:String); var I,CC,X,Y:Integer ; Temp:TStringList; LRect: TRect; begin if aGestureFile='' then Exit; if not FileExists(aGestureFile) then Exit; LRect := ClientRect; Canvas.Brush.Color := Color; Canvas.FillRect(LRect); Temp:=TStringList.Create; try try Temp.LoadFromFile(aGestureFile); except end; if Temp.Count>1 then begin CC:=Temp.Count div 2; X:=0; Y:=0; try X:=StrToInt(Temp.Values['X0']); Y:=StrToInt(Temp.Values['Y0']); except end; Canvas.MoveTo(X,Y); for I := 0 to CC-1 do begin X:=0; Y:=0; try X:=StrToInt(Temp.Values[Format('X%d',[I])]); Y:=StrToInt(Temp.Values[Format('Y%d',[I])]); except end; DrawPoint(Point(X,Y)); Sleep(10); end; end; finally Temp.Free; end; end; procedure TCustomUWSGestureRecord.AddGestureChar(AChar: String); begin if AChar <> FLastPushed then begin FGesture := FGesture +'→'+ AChar; FLastPushed := AChar; end; end; procedure TCustomUWSGestureRecord.AddGesturePoint(const LastPoint, NextPoint: TPoint); var StepX, StepY: Single; I, DeltaX, DeltaY: Integer; CountX, CountY, Count: Integer; begin // Determine distance between points DeltaX := Abs(NextPoint.X - LastPoint.X); DeltaY := Abs(NextPoint.Y - LastPoint.Y); // If points are too close together discard the new point if (DeltaX < 4) and (DeltaY < 4) then Exit; // If points are too far apart insert intermediate points if (DeltaX > 8) or (DeltaY > 8) then begin // Determine how many points to insert CountX := DeltaX div 5; if (DeltaX mod 5) = 0 then Dec(CountX); CountY := DeltaY div 5; if (DeltaY mod 5) = 0 then Dec(CountY); Count := Max(CountX, CountY); // Determine spacing between inserted points StepX := (NextPoint.X - LastPoint.X) / Count; StepY := (NextPoint.Y - LastPoint.Y) / Count; // Insert points for I := 1 to Count - 1 do FRecordedPoints.Add(Point(LastPoint.X + Round(StepX * I), LastPoint.Y + Round(StepY * I))); end; // Add captured point FRecordedPoints.Add(NextPoint); end; function TCustomUWSGestureRecord.PointsToArray(Source: TGesturePoints): TGesturePointArray; var I: Integer; begin SetLength(Result, Source.Count); for I := 0 to Source.Count - 1 do Result[I] := Source[I]; end; procedure TCustomUWSGestureRecord.SetCaption(const Value: string); begin if Value <> FCaption then begin FCaption := Value; Invalidate; end; end; procedure TCustomUWSGestureRecord.StartMouseGesture(AMouseX, AMouseY: Integer); begin // Set recording mode FRecording := True; Invalidate; // Clear list of points FRecordedPoints.Clear; FRecordedPoints.Add(Point(AMouseX, AMouseY)); DrawPoint(FRecordedPoints[0]); FLastDrawnPoint := 0; FLastPushed := #0; FGesture := ''; FTrailActive := True; FTrailLength := 0; FTrailX := AMouseX; FTrailY := AMouseY; FTrailStartTime := now; end; procedure TCustomUWSGestureRecord.ShortGesture; var TempStr:string; Temp:TStringList; I:Integer; begin Temp:=TStringList.Create; try Temp.Delimiter:='→'; Temp.DelimitedText:=FGesture; if Temp.Count>8 then begin for I := 1 to 8 do TempStr:=TempStr+'→'+temp[I]; FGesture:=TempStr; end; finally Temp.Free; end; end; procedure TCustomUWSGestureRecord.EndMouseGesture(AMouseX, AMouseY: Integer); var Index: Integer; begin if not FRecording then Exit; FTrailActive := False; FRecording := False; // Add new gesture point AddGesturePoint(FRecordedPoints[FRecordedPoints.Count - 1], Point(AMouseX, AMouseY)); // Normalize list of points FPoints := NormalizePoints(PointsToArray(FRecordedPoints)); ShortGesture; FCaption:=FGesture ; // Trigger OnRecorded event if more than 1 point was recorded if (Length(FPoints) > 1) then begin end; FGestureFileName:=GesturetoGestureFileName(FGesture); DoMouseGestureCustomInterpretation(FGesture); // Force repaint Invalidate; end; procedure TCustomUWSGestureRecord.TrailMouseGesture(AMouseX, AMouseY: Integer); var locX: Integer; locY: Integer; x_dir: Integer; y_dir: Integer; tolerancePercent: Double; x_divide_y: Double; y_divide_x: Double; I:Integer; function InBetween(AValue, AMin, AMax: Double): Boolean; begin Result := (AValue >= AMin) and (AValue <= AMax); end; begin if not FRecording then Exit; // Add new gesture point AddGesturePoint(FRecordedPoints[FRecordedPoints.Count - 1], Point(AMouseX, AMouseY)); for I := FLastDrawnPoint to FRecordedPoints.Count - 1 do DrawPoint(FRecordedPoints[I]); FLastDrawnPoint := FRecordedPoints.Count - 1; if (not FTrailActive) or (FTrailLength > FTrailLimit) then begin FTrailActive := False; Exit; end; try x_dir := AMouseX - FTrailX; y_dir := AMouseY - FTrailY; locX := abs(x_dir); locY := abs(y_dir); // process each half-grid if (locX >= FGridHalf) or (locY >= FGridHalf) then begin // diagonal movement: // dTolerance = 75 means that a movement is recognized as diagonal when // x/y or y/x is between 0.25 and 1 tolerancePercent := 1 - FdTolerance / 100; if locY <> 0 then x_divide_y := locX / locY else x_divide_y := 0; if locX <> 0 then y_divide_x := locY / locX else y_divide_x := 0; if (FdTolerance <> 0) and (InBetween(x_divide_y, tolerancePercent, 1) or InBetween(y_divide_x, tolerancePercent, 1)) then begin if (x_dir < -6) and (y_dir > 6) then begin AddGestureChar('向左斜下'); end else begin if (x_dir > 6) and (y_dir > 6) then AddGestureChar('向右斜下') else begin if (x_dir < -6) and (y_dir < -6) then AddGestureChar('向左斜上') else begin if (x_dir > 6) and (y_dir < -6) then AddGestureChar('向右斜上'); end; end; end; end // of diaognal else begin // horizontal movement: if locX > locY then begin if x_dir > 0 then AddGestureChar('向右') else begin if x_dir < 0 then AddGestureChar('向左'); end; end else begin // vertical movement: if locX < locY then begin if y_dir > 0 then AddGestureChar('向下') else begin if y_dir < 0 then AddGestureChar('向上'); end; end; end; end; end; // of half grid finally FTrailX := AMouseX; FTrailY := AMouseY; end; DoTrailingGesture(FGesture); end; procedure TCustomUWSGestureRecord.SetGestureLineColor(const Value: TColor); begin if Value <> FGestureLineColor then begin FGestureLineColor := Value; Invalidate; end; end; procedure TCustomUWSGestureRecord.SetGesturePointColor(const Value: TColor); begin if Value <> FGesturePointColor then begin FGesturePointColor := Value; Invalidate; end; end; procedure TCustomUWSGestureRecord.DrawPoint(const Point: TPoint); begin Canvas.Brush.Style := bsClear; Canvas.Pen.Width:=17; Canvas.Pen.Color := FGesturePointColor; Canvas.Ellipse(Point.X - 2, Point.Y - 2, Point.X + 3, Point.Y + 3); Canvas.Pen.Color := FGestureLineColor; if FRecordedPoints.Count = 1 then Canvas.MoveTo(Point.X, Point.Y) else Canvas.LineTo(Point.X, Point.Y); end; procedure TCustomUWSGestureRecord.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin if Button<>mbLeft then Exit; StartMouseGesture(X,Y); end; procedure TCustomUWSGestureRecord.MouseMove(Shift: TShiftState; X, Y: Integer); begin TrailMouseGesture(X,Y); end; function TCustomUWSGestureRecord.NormalizePoints( const Points: array of TPoint): TGesturePointArray; var Index, SmallestX, SmallestY: Integer; begin SetLength(Result, Length(Points)); // Find the delta. SmallestX := MaxInt; SmallestY := MaxInt; for Index := 0 to Length(Points) - 1 do begin if SmallestX > Points[Index].X then SmallestX := Points[Index].X; if SmallestY > Points[Index].Y then SmallestY := Points[Index].Y; end; // Apply the delta. SetLength(Result, Length(Points)); for Index := 0 to Length(Points) - 1 do Result[Index] := Point(Points[Index].X - SmallestX, Points[Index].Y - SmallestY); end; procedure TCustomUWSGestureRecord.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin EndMouseGesture(X,Y); end; procedure TCustomUWSGestureRecord.WndProc(var Message: TMessage); begin inherited WndProc(Message); end; procedure TCustomUWSGestureRecord.Paint; var LRect: TRect; LText: string; I, LTextHeight: Integer; begin LRect := ClientRect; Canvas.Brush.Color := Color; Canvas.FillRect(LRect); if (not FRecording) and (not FPlaying) then begin // Draw instructions Canvas.Font := Self.Font; Canvas.Brush.Style := bsClear; if FCaption='' then FCaption:=FGesture ; LText := FCaption; if (csDesigning in ComponentState) and (LText = '') then LText := Name; InflateRect(LRect, -25, 0); LRect.Top := 0; LRect.Bottom := 0; Canvas.TextRect(LRect, LText, [tfCalcRect, tfWordBreak]); LRect.Right := Width - 25; LTextHeight := LRect.Bottom - LRect.Top; LRect.Top := (Height - LTextHeight) div 2; Inc(LRect.Bottom, LRect.Top); Canvas.TextRect(LRect, LText, [tfCenter, tfWordBreak]); end else begin // Draw points for I := 0 to FRecordedPoints.Count - 1 do DrawPoint(FRecordedPoints[I]) end; end; function TCustomUWSGestureRecord.DoMouseGestureCustomInterpretation(const AGesture: string): Boolean; begin Result := Assigned(FOnMouseGestureCustomInterpretation); if Result then begin FOnMouseGestureCustomInterpretation(Self,FGesture); end; end; function TCustomUWSGestureRecord.DoTrailingGesture(const AGesture: string): Boolean; begin Result := Assigned(FOnTrailingGesture); if Result then begin FOnTrailingGesture(Self,FGesture); end; end; end.
改造过的JvMouseGesture.pas和鼠标手势定义组件下载：
效果图
暂时就记录到这里
代码在Delphi XE中测试通过，其他版本未经测试