Virtuelles Keyboard für ein bestimmtes Control deaktivieren

[Sir Rufo]

Dieses VK ist schon als ein ganz übler Timer-Dschungel konzipiert. Da bleibt nur die Option, diese Automatik auszuschalten und selber zu implementieren.

Hier mal so ein VirtualKeyboardService. Der läuft auf Android (nach einem kurzen Test) recht brauchbar und auf Windows kann der sich auch schon mal verhaspeln (allerdings auch nicht mehr, als es das Standard-Verhalten auch macht).

Delphi-Quellcode:

unit Common.FMX.VirtualKeyboardService;

interface

uses
  FMX.Types,
  FMX.VirtualKeyboard,
  System.Generics.Collections,
  System.Classes,
  System.Messaging;

type
  TVirtualKeyboardService = class( TComponent )
  private type
    TVKState = ( Hidden, Showing, Visible, Hiding );
  private
    FVKSvc: IFMXVirtualKeyboardService;
    FState: TVKState;
    FObjects: TList<TFmxObject>;
    constructor Create( AOwner: TComponent );
    class constructor Create;

    procedure DoWork( );

    procedure HandleIdleMessage( const Sender: TObject; const M: System.Messaging.TMessage );
    procedure HandleVKStateChangeMessage( const Sender: TObject; const M: System.Messaging.TMessage );
  protected
    procedure Notification( AComponent: TComponent; Operation: TOperation ); override;
  public
    class function Current: TVirtualKeyboardService;
    destructor Destroy; override;

    procedure AfterConstruction; override;
    procedure BeforeDestruction; override;

    procedure AddOverrideObject( AObject: TFmxObject );
    procedure RemoveOverrideObject( AObject: TFmxObject );
    function IsOverriddenObject( AObject: TFmxObject ): Boolean;
  private
    class var _current: TVirtualKeyboardService;
  end;

implementation

uses
  System.SysUtils,
  FMX.Forms,
  FMX.Platform;

{ TVirtualKeyboardService }

constructor TVirtualKeyboardService.Create( AOwner: TComponent );
begin
  inherited Create( AOwner );
  if TPlatformServices.Current.SupportsPlatformService( IFMXVirtualKeyboardService, FVKSvc ) then
    VKAutoShowMode := TVKAutoShowMode.Never;
  FObjects := TList<TFmxObject>.Create;
end;

procedure TVirtualKeyboardService.AddOverrideObject( AObject: TFmxObject );
begin
  if Supports( AObject, IVirtualKeyboardControl ) and not FObjects.Contains( AObject ) then
  begin
    FObjects.Add( AObject );
    Self.FreeNotification( AObject );
  end;
end;

procedure TVirtualKeyboardService.AfterConstruction;
begin
  inherited;
  TMessageManager.DefaultManager.SubscribeToMessage( TVKStateChangeMessage, HandleVKStateChangeMessage );
  TMessageManager.DefaultManager.SubscribeToMessage( TIdleMessage, HandleIdleMessage );
end;

procedure TVirtualKeyboardService.BeforeDestruction;
begin
  TMessageManager.DefaultManager.Unsubscribe( TIdleMessage, HandleIdleMessage );
  TMessageManager.DefaultManager.Unsubscribe( TVKStateChangeMessage, HandleVKStateChangeMessage );
  inherited;
end;

class constructor TVirtualKeyboardService.Create;
begin
  TVirtualKeyboardService._current := TVirtualKeyboardService.Create( Application );
end;

class function TVirtualKeyboardService.Current: TVirtualKeyboardService;
begin
  Result := _current;
end;

destructor TVirtualKeyboardService.Destroy;
begin
  FObjects.Free;
  inherited;
end;

procedure TVirtualKeyboardService.DoWork;
var
  LCurrentObject: TFmxObject;
  LNewState: TVKState;
begin
  if not Assigned( FVKSvc ) or not( VKAutoShowMode = TVKAutoShowMode.Never ) then
    Exit;

  LCurrentObject := nil;
  if Assigned( Screen.ActiveForm ) and Assigned( Screen.ActiveForm.Focused ) then
    LCurrentObject := Screen.ActiveForm.Focused.GetObject;

  if ( LCurrentObject = nil ) or not Supports( LCurrentObject, IVirtualKeyboardControl ) or FObjects.Contains( LCurrentObject ) then
    LNewState := TVKState.Hidden
  else
    LNewState := TVKState.Visible;

  if FState <> LNewState then
  begin
    if ( LNewState = TVKState.Hidden ) and ( FState = TVKState.Hiding ) then
      Exit;
    if ( LNewState = TVKState.Visible ) and ( FState = TVKState.Showing ) then
      Exit;

    case LNewState of
      Hidden:
        begin
          FVKSvc.HideVirtualKeyboard;
          FState := TVKState.Hiding;
        end;
      Visible:
        begin
          FVKSvc.ShowVirtualKeyboard( LCurrentObject );
          FState := TVKState.Showing;
        end;
    end;
  end;
end;

procedure TVirtualKeyboardService.HandleIdleMessage( const Sender: TObject; const M: System.Messaging.TMessage );
begin
  DoWork( );
end;

procedure TVirtualKeyboardService.HandleVKStateChangeMessage( const Sender: TObject; const M: System.Messaging.TMessage );
var
  LMsg: TVKStateChangeMessage absolute M;
begin
  if LMsg.KeyboardVisible then
    FState := TVKState.Visible
  else
    FState := TVKState.Hidden;
end;

function TVirtualKeyboardService.IsOverriddenObject( AObject: TFmxObject ): Boolean;
begin
  Result := FObjects.Contains( AObject );
end;

procedure TVirtualKeyboardService.Notification( AComponent: TComponent; Operation: TOperation );
begin
  inherited;
  if ( Operation = opRemove ) and ( AComponent is TFmxObject ) then
  begin
    RemoveOverrideObject( AComponent as TFmxObject );
  end;
end;

procedure TVirtualKeyboardService.RemoveOverrideObject( AObject: TFmxObject );
begin
  if FObjects.Contains( AObject ) then
  begin
    FObjects.Remove( AObject );
    Self.RemoveFreeNotification( AObject );
  end;
end;

end.

Die Verwendung ist eigentlich recht simpel:

Delphi-Quellcode:

unit Form.MainForm;

interface

uses
  System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants,
  FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs,
  FMX.Controls.Presentation, FMX.Edit, FMX.StdCtrls, FMX.ScrollBox, FMX.Memo,
  FMX.Layouts, FMX.ListBox;

type
  TMainForm = class( TForm )
    Edit1: TEdit;
    Edit2: TEdit;
    Edit3: TEdit;
  private
  public
    procedure AfterConstruction; override;

  end;

var
  MainForm: TMainForm;

implementation

{$R *.fmx}

uses
  Common.FMX.VirtualKeyboardService;

procedure TMainForm.AfterConstruction;
begin
  inherited;
  TVirtualKeyboardService.Current.AddOverrideObject( Edit2 );
end;

end.

Und schon hat Edit2 kein VirtualKeyboard mehr ...