Screen.Cursor in Firemonkey

Question

In Delphi 6, I could change the Mouse Cursor for all forms using Screen.Cursor:

procedure TForm1.Button1Click(Sender: TObject);
begin
  Screen.Cursor := crHourglass;
end;

I am searching the equivalent in Firemonkey.

Following function does not work:

procedure SetCursor(ACursor: TCursor);
var
  CS: IFMXCursorService;
begin
  if TPlatformServices.Current.SupportsPlatformService(IFMXCursorService) then
  begin
    CS := TPlatformServices.Current.GetPlatformService(IFMXCursorService) as IFMXCursorService;
  end;
  if Assigned(CS) then
  begin
    CS.SetCursor(ACursor);
  end;
end;

When I insert a Sleep(2000); at the end of the procedure, I can see the cursor for 2 seconds. But the Interface probably gets freed and therefore, the cursor gets automatically resetted at the end of the procedure. I also tried to define CS as a global variable, and add CS._AddRef at the end of the procedure to prevent the Interface to be freed. But it did not help either.

Following code does work, but will only work for the main form:

procedure TForm1.Button1Click(Sender: TObject);
begin
  Application.MainForm.Cursor := crHourGlass;
end;

Since I want to change the cursor for all forms, I would need to iterate through all forms, but then the rollback to the previous cursors is tricky, as I need to know the previous cursor for every form.

My intention:

procedure TForm1.Button1Click(Sender: TObject);
var
  prevCursor: TCursor;
begin
  prevCursor := GetCursor;
  SetCursor(crHourglass); // for all forms
  try
    Work;
  finally
    SetCursor(prevCursor);
  end;
end;

Answer 1

You'd have to implement your own cursor service that makes it possible to enforce a certain cursor.

unit Unit2;

interface

uses
  FMX.Platform, FMX.Types, System.UITypes;

type
  TWinCursorService = class(TInterfacedObject, IFMXCursorService)
  private
    class var FPreviousPlatformService: IFMXCursorService;
    class var FWinCursorService: TWinCursorService;
    class var FCursorOverride: TCursor;
    class procedure SetCursorOverride(const Value: TCursor); static;
  public
    class property CursorOverride: TCursor read FCursorOverride write SetCursorOverride;

    class constructor Create;
    procedure SetCursor(const ACursor: TCursor);
    function GetCursor: TCursor;
  end;

implementation

{ TWinCursorService }

class constructor TWinCursorService.Create;
begin
  FWinCursorService := TWinCursorService.Create;

  FPreviousPlatformService := TPlatformServices.Current.GetPlatformservice(IFMXCursorService) as IFMXCursorService; // TODO: if not assigned

  TPlatformServices.Current.RemovePlatformService(IFMXCursorService);
  TPlatformServices.Current.AddPlatformService(IFMXCursorService, FWinCursorService);
end;

function TWinCursorService.GetCursor: TCursor;
begin
  result :=  FPreviousPlatformService.GetCursor;
end;

procedure TWinCursorService.SetCursor(const ACursor: TCursor);
begin
  if FCursorOverride = crDefault then
  begin
    FPreviousPlatformService.SetCursor(ACursor);
  end
  else
  begin
    FPreviousPlatformService.SetCursor(FCursorOverride);
  end;
end;


class procedure TWinCursorService.SetCursorOverride(const Value: TCursor);
begin
  FCursorOverride := Value;
  TWinCursorService.FPreviousPlatformService.SetCursor(FCursorOverride);
end;

end.

MainUnit:

procedure TForm1.Button1Click(Sender: TObject);
var
  i: integer;
begin
  TWinCursorService.CursorOverride := crHourGlass;
  try
    Sleep(2000);
  finally
    TWinCursorService.CursorOverride := crDefault;
  end;
end;