Getting gesture distance in Delphi

There are two types of touch screens supported in Windows - one that detect gestures natively and uses special messages for them and another that uses mouse emulation and sends standard mouse messages on touch events. Delphi detects both these types and uses appropriate gesture engine internally. There is however a problem with mouse gesture engine in that it does not report distance that you swiped on the screen. This means that there could be false positives when user just wanted to press button but system detects it as gesture. Fortunately it is pretty easy to replace mouse gesture engine with custom implementation. This implementation will be almost exactly the same as standard TMouseGestureEngine. Since it is a sealed class we cannot inherit from it so we will need to copy it completely to new unit from Vcl.Touch.Gestures and call it for example TMouseGestureEngineEx Here are modifications that are needed for this class

// function that calculates distance between to points
function Distance(Point1, Point2: TPoint): Integer;
begin
  Result := Round(Sqrt(Sqr(Point1.X - Point2.X) + Sqr(Point1.Y - Point2.Y)));
end;

procedure TMouseGestureEngineEx.Notification(const Message: TMessage);

// .....

            if (LGestureList.Count > 0) and
               TGestureEngine.IsGesture(Points, LGestureList, [gtStandard] + [gtRecorded, gtRegistered], LEventInfo) then
            begin
              // add this line to set distance
              LEventInfo.Distance := Distance(Points[Low(Points)], Points[High(Points)]);
              BroadcastGesture(TargetControl, LEventInfo);
            end;

// ...

// registering our new gesture engine
initialization
  TGestureEngine.DefaultEngineClass := TMouseGestureEngineEx;
end.

Now in gesture event we can check EventInfo.Distance field

procedure TForm1.FormGesture(Sender: TObject;
  const EventInfo: TGestureEventInfo; var Handled: Boolean);
begin
  Label1.Caption := 'Distance ' + IntToStr(EventInfo.Distance);
end;

This kind of calculation will work only for simple gestures because it calculates distance only between first and last points of swipe.

Mocking IDispatch interfaces in Delphi

Sometimes it is needed to write unit tests for code that uses third party ActiveX control. In this case we have to create mock of this ActiveX control. This is easy to do with standard Delphi TObjectDispatch class which creates IDispatch interface from normal class. Here is simple example

{$APPTYPE CONSOLE}

program TestDispatch;

uses System.Win.ObjComAuto;

{$METHODINFO ON}

type
  TTestWriter = class
    procedure Write(const Data: string); 
  end;

procedure TTestWriter.Write(const Data: string); 
begin
  Writeln(Data);
end;

var
  Dispatch: IDispatch;
  OleDispatch: OleVariant;
  TestWriter: TTestWriter;
begin
  TestWriter := TTestWriter.Create;
  Dispatch := TObjectDispatch.Create(TestWriter, True);
  OleDispatch := Dispatch;
  OleDispatch.Write('test');
end.

This works when we use OleVariant and late binding of IDispatch methods, but if we use dispinterface this will not work because TObjectDispatch generates dispid's for methods internally and does not allow to modify them. To overcome this problem we can create following TObjectDispatch extension class that will map real dispid values to auto generated ones.

unit uObjectDispatchWrapper;
interface

uses System.Win.ObjComAuto, System.Generics.Collections, System.Types, System.SysUtils;

type
  TObjectDispatchWrapper = class(TObjectDispatch)
  strict private
    FDispIDsMapping: TDictionary<Integer, Integer>;
  public
    constructor Create(Instance: TObject; const AMethods: TStringDynArray; const AMethodDispIDs: TIntegerDynArray);
    function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
      Flags: Word; var Params; VarResult: Pointer; ExcepInfo: Pointer;
      ArgErr: Pointer): HRESULT; override; stdcall;
    destructor Destroy; override;
  end;

implementation

constructor TObjectDispatchWrapper.Create(Instance: TObject; const AMethods: TStringDynArray; const AMethodDispIDs: TIntegerDynArray);
var
  i: Integer;
  MethodName: string;
  DispatchIdentifier: Integer;
begin
  Assert(Length(AMethods) = Length(AMethodDispIDs));
  inherited Create(Instance, True);
  FDispIDsMapping := TDictionary<Integer, Integer>.Create;

  // call GetIDsOfNames for all methods to populate internal TObjectDispatch data
  // this is needed because when used with dispinterfaces GetIDsOfNames method is not called.
  for i := Low(AMethods) to High(AMethods) do
  begin
    MethodName := AMethods[i];
    GetIDsOfNames(GUID_NULL, @MethodName, 1, SysLocale.DefaultLCID, @DispatchIdentifier);
    FDispIDsMapping.Add(AMethodDispIDs[i], DispatchIdentifier);
  end;
end;

destructor TObjectDispatchWrapper.Destroy;
begin
  FDispIDsMapping.Free;
  inherited;
end;

function TObjectDispatchWrapper.Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
  Flags: Word; var Params; VarResult: Pointer; ExcepInfo: Pointer;
  ArgErr: Pointer): HRESULT;
begin
  Result := inherited Invoke(FDispIDsMapping[DispID], IID, LocaleID, Flags, Params, VarResult, ExcepInfo, ArgErr);
end;

end.

And here is an example of its usage

{$APPTYPE CONSOLE}

program TestDisp;

uses System.Types, System.Win.ObjComAuto, uObjectDispatchWrapper;

{$METHODINFO ON}

type
  ITestWriter = dispinterface
    ['{4861977E-7E28-4195-BC7A-F45005536FEB}']
    procedure Write(const Data: string); dispid 5;
  end;

  TTestWriter = class
    procedure Write(const Data: string); 
  end;

procedure TTestWriter.Write(const Data: string); 
begin
  Writeln(Data);
end;

var
  Dispatch: IDispatch;
  TestWriter: TTestWriter;
begin
  TestWriter := TTestWriter.Create;
  Dispatch := TObjectDispatchWrapper.Create(TestWriter, 
    // method Write has dispid 5 
    TStringDynArray.Create('Write'), TIntegerDynArray.Create(5)
  );
  ITestWriter(Dispatch).Write('test');
end.

On a side note - dispinterfaces generated from ActiveX controls usually use WideString type for parameters, but there seems to be a bug in TObjectDispatch with WideString parameters so string type have to be used in mock class instead.
On another side note - word 'dispatch' in exe name seems to trigger Windows protection mechanism and it requires admin writes to run, so it is better to call project file TestDisp instead of TestDispatch.