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;

Answer 2

The IFMXCursorService is how the FMX framework manages cursors. It is not intended for your use. The mechanism that you are meant to use is the form's Cursor property.

This means that you will need to remember the cursor for each form in order to restore it. I suggest that you use a dictionary to do that. Wrap the functionality up into a small class and then at least the pain is localized to the implementation of that class. You can make the code at the call site reasonable.