“Hooking” KeyDown in a Firemonkey form

 Delphi, dzLib  Comments Off on “Hooking” KeyDown in a Firemonkey form
Jun 182016
 

As said in my last post: " The hard part is hooking the form in a way so all I need to do is call TForm_ActivatePositioning as in the VCL."

As it turns out, that’s even easier to do than in the VCL. No subclassing of the window, just adding a new control is sufficient. As this StackOverflow answer points out, a Firemonkey form calls the DialogKey method of all its child controls when a key is pressed, starting with the one that has got the focus. So, all we’ve got to do is creating a control that handles the keys we want to intercept and add it to the form.

Here is the code:

type
  TFormPositioningActivator = class(TControl)
  private
    FModifier: TShiftState;
  protected
    procedure DialogKey(var Key: Word; Shift: TShiftState); override;
  public
    constructor Create(_Form: TCustomForm; _Modifier: TShiftState); reintroduce;
  end;

{ TFormHookChild }

constructor TFormPositioningActivator.Create(_Form: TCustomForm; _Modifier: TShiftState);
begin
  inherited Create(_Form);
  FModifier := _Modifier;
  Parent := _Form;
end;

procedure TFormPositioningActivator.DialogKey(var Key: Word; Shift: TShiftState);
begin
  inherited;
  if Shift = FModifier then begin
    case Key of
      vkLeft: TForm_MoveTo(self.Parent as TForm, dwpLeft);
      vkRight: TForm_MoveTo(self.Parent as TForm, dwpRight);
      vkUp: TForm_MoveTo(self.Parent as TForm, dwpTop);
      vkDown: TForm_MoveTo(self.Parent as TForm, dwpBottom);
      vkHome: TForm_MoveTo(self.Parent as TForm, dwpTopLeft);
      vkEnd: TForm_MoveTo(self.Parent as TForm, dwpBottomLeft);
      vkPrior: TForm_MoveTo(self.Parent as TForm, dwpTopRight);
      vkNext: TForm_MoveTo(self.Parent as TForm, dwpBottomRight);
    else
      Exit; // so Key doesn't get set to 0
    end;
    Key := 0;
  end;

end;

function TForm_ActivatePositioning(_Form: TForm; _Modifier: TShiftState = [ssCtrl, ssAlt]): TObject;
begin
  Result := TFormPositioningActivator.Create(_Form, _Modifier);
end;

All you have to do is call TForm_ActivatePositioning(Self) in the form’s constructor and be done.

 Posted by on 2016-06-18 at 15:11

Snapping a Firemonkey window to monitor halves / quadrants

 Delphi, dzLib  Comments Off on Snapping a Firemonkey window to monitor halves / quadrants
Jun 182016
 

I always wanted to start playing with Firemonkey but so far just didn’t find the right project. This is my first try to port a VCL utility function to Firemonkey. Note that this will probably not work on all platforms. It’s tested on Windows only.

So, how do we get the code from my last post to work with a Firemonkey program? It turned out to be not too difficult. Monitors have been renamed to Displays, TForm.BoundsRect is now only TForm.Bounds. There doesn’t seem to be an equivalent to TForm.Constraints (even though Simon J. Stuart has posted a TConstraintForm solution on StackOverflow) so we will for now ignore that.

Here is the code:

procedure TForm_MoveTo(_frm: TCustomForm; _Position: TdzWindowPositions);

  procedure ToTop(var _Re: TRect; _MinHeight, _MaxHeight: Integer);
  begin
    _Re.Bottom := _Re.Top + _Re.Height div 2;
    if _Re.Height < _MinHeight then
      _Re.Bottom := _Re.Top + _MinHeight;
    if (_MaxHeight > 0) and (_Re.Height > _MaxHeight) then
      _Re.Bottom := _Re.Top + _MaxHeight;
  end;

  procedure ToBottom(var _Re: TRect; _MinHeight, _MaxHeight: Integer);
  begin
    _Re.Top := _Re.Top + _Re.Height div 2;
    if _Re.Height < _MinHeight then
      _Re.Top := _Re.Bottom - _MinHeight;
    if (_MaxHeight > 0) and (_Re.Height > _MaxHeight) then
      _Re.Top := _Re.Bottom - _MaxHeight;
  end;

  procedure ToLeft(var _Re: TRect; _MinWidth, _MaxWidth: Integer);
  begin
    _Re.Right := _Re.Left + _Re.Width div 2;
    if _Re.Width < _MinWidth then
      _Re.Right := _Re.Left + _MinWidth;
    if (_MaxWidth > 0) and (_Re.Width > _MaxWidth) then
      _Re.Right := _Re.Left + _MaxWidth;
  end;

  procedure ToRight(var _Re: TRect; _MinWidth, _MaxWidth: Integer);
  begin
    _Re.Left := _Re.Left + _Re.Width div 2;
    if _Re.Width < _MinWidth then
      _Re.Left := _Re.Right - _MinWidth;
    if (_MaxWidth > 0) and (_Re.Width > _MaxWidth) then
      _Re.Left := _Re.Right - _MaxWidth;
  end;

  function TryMonitorFromPoint(_pnt: TPoint; out _Display: TDisplay): boolean;
  var
    i: Integer;
    Display: TDisplay;
  begin
    Result := False;
    for i := 0 to Screen.DisplayCount - 1 do begin
      Display := Screen.Displays[i];
      Result := Display.WorkArea.Contains(_pnt);
      if Result then begin
        _Display := Display;
        Exit;
      end;
    end;
  end;

type
  TDummyConstraints = record
    MinWidth, MaxWidth: Integer;
    MinHeight, MaxHeight: Integer;
  end;
var
  re: TRect;
  Bounds: TRect;
  NewMonitor: TDisplay;
  Constraints: TDummyConstraints;
begin
  re := Screen.DisplayFromForm(_frm).WorkareaRect;
  Bounds := _frm.Bounds;
  Constraints.MinWidth := 0;
  Constraints.MaxWidth := 0;
  Constraints.MinHeight := 0;
  Constraints.MaxHeight := 0;
  case _Position of
    dwpTop: begin
        ToTop(re, Constraints.MinHeight, Constraints.MaxHeight);
        if re = Bounds then begin
          if TryMonitorFromPoint(Point((re.Left + re.Right) div 2, re.Top - re.Height div 2), NewMonitor) then begin
            re := NewMonitor.WorkareaRect;
            ToBottom(re, Constraints.MinHeight, Constraints.MaxHeight);
          end;
        end;
      end;
    dwpBottom: begin
        ToBottom(re, Constraints.MinHeight, Constraints.MaxHeight);
        if re = Bounds then begin
          if TryMonitorFromPoint(Point((re.Left + re.Right) div 2, re.Bottom + re.Height div 2), NewMonitor) then begin
            re := NewMonitor.WorkareaRect;
            ToTop(re, Constraints.MinHeight, Constraints.MaxHeight);
          end;
        end;
      end;
    dwpLeft: begin
        ToLeft(re, Constraints.MinWidth, Constraints.MaxWidth);
        if re = Bounds then begin
          if TryMonitorFromPoint(Point(re.Left - re.Width div 2, (re.Top + re.Bottom) div 2), NewMonitor) then begin
            re := NewMonitor.WorkareaRect;
            ToRight(re, Constraints.MinWidth, Constraints.MaxWidth);
          end;
        end;
      end;
    dwpRight: begin
        ToRight(re, Constraints.MinWidth, Constraints.MaxWidth);
        if re = Bounds then begin
          if TryMonitorFromPoint(Point(re.Right + re.Width div 2, (re.Top + re.Bottom) div 2), NewMonitor) then begin
            re := NewMonitor.WorkareaRect;
            ToLeft(re, Constraints.MinWidth, Constraints.MaxWidth);
          end;
        end;
      end;
    dwpTopLeft: begin
        ToTop(re, Constraints.MinHeight, Constraints.MaxHeight);
        ToLeft(re, Constraints.MinWidth, Constraints.MaxWidth);
      end;
    dwpTopRight: begin
        ToTop(re, Constraints.MinHeight, Constraints.MaxHeight);
        ToRight(re, Constraints.MinWidth, Constraints.MaxWidth);
      end;
    dwpBottomLeft: begin
        ToBottom(re, Constraints.MinHeight, Constraints.MaxHeight);
        ToLeft(re, Constraints.MinWidth, Constraints.MaxWidth);
      end;
    dwpBottomRight: begin
        ToBottom(re, Constraints.MinHeight, Constraints.MaxHeight);
        ToRight(re, Constraints.MinWidth, Constraints.MaxWidth);
      end;
  end;
  _frm.Bounds := re;
end;

As you can see, the implementation is very similar to the VCL implementation. With a bit of effort I could probably make them nearly indistinguishable.

It’s in dzlib, in unit u_dzFmxUtils

Now, that was the easy part: Moving the form. The hard part is hooking the form in a way so all I need to do is call TForm_ActivatePositioning as in the VCL. No idea yet on how to accomplish that, but I’m just getting started with Firemonkey.

 Posted by on 2016-06-18 at 12:30

Snapping windows to monitor halves / quadrants revisited

 Delphi, dzLib  Comments Off on Snapping windows to monitor halves / quadrants revisited
Jun 182016
 

In my last post I talked about snapping windows to monitor halves and quadrants. I have been using that code for a few days and found it has a few shortcomings:

  1. If a window has size constraints, these will still be respected (which is good) but this will result in the window not being moved correctly. Snapping to the left and top half works fine, but snapping to the right or bottom half will move part of the window outside the active monitor.
  2. If a window has size constraints, moving from the left half of the right hand side monitor to the right half of left hand side monitor will not work. the same applies from the top half of the bottom monitor to the bottom half of the top monitor.
  3. It’s a bit inconvenient to move a window from a quadrant of one monitor to a quadrant of a different monitor. E.g. sometimes I want to move a window from the top right quadrant of the right hand side monitor to the top right quadrant of the left hand side monitor and vice versa. In order to do that I have to press Ctrl+Alt+Left (moves it to the left half of that monitor) Ctrl+Alt+Left (moves it to the right half of the other monitor) Ctrl+Alt+PgUp (finally moves it to the top right quadrant of that monitor). It would be nice to accomplish this
    1. with less key strokes
    2. without resizing the window

    Currently I am leaning towards Ctrl+Alt+PgUp moving the window to the top right quadrant of the same monitor and pressing it again moving it to the same quadrant of the monitor to the right of that monitor, or if that doesn’t exist, to the monitor above. But I’m not yet sure about the order of monitors here. If you want to voice your opinion, use my corresponding Google+ post

The fix for the constraints issues isn’t that difficult: Just read the form’s constraints and adjust the position accordingly. Here is the new code:

procedure TForm_MoveTo(_frm: TCustomForm; _Position: TdzWindowPositions);

  procedure ToTop(var _Re: TRect; _MinHeight, _MaxHeight: Integer);
  begin
    _Re.Bottom := _Re.Top + TRect_Height(_Re) div 2;
    if TRect_Height(_Re) < _MinHeight then
      _Re.Bottom := _Re.Top + _MinHeight;
    if (_MaxHeight > 0) and (TRect_Height(_Re) > _MaxHeight) then
      _Re.Bottom := _Re.Top + _MaxHeight;
  end;

  procedure ToBottom(var _Re: TRect; _MinHeight, _MaxHeight: Integer);
  begin
    _Re.Top := _Re.Top + TRect_Height(_Re) div 2;
    if TRect_Height(_Re) < _MinHeight then
      _Re.Top := _Re.Bottom - _MinHeight;
    if (_MaxHeight > 0) and (TRect_Height(_Re) > _MaxHeight) then
      _Re.Top := _Re.Bottom - _MaxHeight;
  end;

  procedure ToLeft(var _Re: TRect; _MinWidth, _MaxWidth: Integer);
  begin
    _Re.Right := _Re.Left + TRect_Width(_Re) div 2;
    if TRect_Width(_Re) < _MinWidth then
      _Re.Right := _Re.Left + _MinWidth;
    if (_MaxWidth > 0) and (TRect_Width(_Re) > _MaxWidth) then
      _Re.Right := _Re.Left + _MaxWidth;
  end;

  procedure ToRight(var _Re: TRect; _MinWidth, _MaxWidth: Integer);
  begin
    _Re.Left := _Re.Left + TRect_Width(_Re) div 2;
    if TRect_Width(_Re) < _MinWidth then
      _Re.Left := _Re.Right - _MinWidth;
    if (_MaxWidth > 0) and (TRect_Width(_Re) > _MaxWidth) then
      _Re.Left := _Re.Right - _MaxWidth;
  end;

  function SamePoint(const _pnt1, _pnt2: TPoint): Boolean;
  begin
    Result := (_pnt1.X = _pnt2.X) and (_pnt1.Y = _pnt2.Y);
  end;

  function SameRect(const _re1, _re2: TRect): Boolean;
  begin
    Result := SamePoint(_re1.TopLeft, _re2.TopLeft) and SamePoint(_re1.BottomRight, _re2.BottomRight);
  end;

var
  re: TRect;
  Bounds: TRect;
  NewMonitor: TMonitor;
  Constraints: TSizeConstraints;
begin
  re := _frm.Monitor.WorkareaRect;
  Bounds := _frm.BoundsRect;
  Constraints := _frm.Constraints;
  case _Position of
    dwpTop: begin
        ToTop(re, Constraints.MinHeight, Constraints.MaxHeight);
        if SameRect(re, Bounds) then begin
          NewMonitor := MonitorFromPoint(Point((re.Left + re.Right) div 2, re.Top - TRect_Height(re) div 2));
          if Assigned(NewMonitor) then begin
            re := NewMonitor.WorkareaRect;
            ToBottom(re, Constraints.MinHeight, Constraints.MaxHeight);
          end;
        end;
      end;
    dwpBottom: begin
        ToBottom(re, Constraints.MinHeight, Constraints.MaxHeight);
        if SameRect(re, Bounds) then begin
          NewMonitor := MonitorFromPoint(Point((re.Left + re.Right) div 2, re.Bottom + TRect_Height(re) div 2));
          if Assigned(NewMonitor) then begin
            re := NewMonitor.WorkareaRect;
            ToTop(re, Constraints.MinHeight, Constraints.MaxHeight);
          end;
        end;
      end;
    dwpLeft: begin
        ToLeft(re, Constraints.MinWidth, Constraints.MaxWidth);
        if SameRect(re, Bounds) then begin
          NewMonitor := MonitorFromPoint(Point(re.Left - TRect_Width(re) div 2, (re.Top + re.Bottom) div 2));
          if Assigned(NewMonitor) then begin
            re := NewMonitor.WorkareaRect;
            ToRight(re, Constraints.MinWidth, Constraints.MaxWidth);
          end;
        end;
      end;
    dwpRight: begin
        ToRight(re, Constraints.MinWidth, Constraints.MaxWidth);
        if SameRect(re, Bounds) then begin
          NewMonitor := MonitorFromPoint(Point(re.Right + TRect_Width(re) div 2, (re.Top + re.Bottom) div 2));
          if Assigned(NewMonitor) then begin
            re := NewMonitor.WorkareaRect;
            ToLeft(re, Constraints.MinWidth, Constraints.MaxWidth);
          end;
        end;
      end;
    dwpTopLeft: begin
        ToTop(re, Constraints.MinHeight, Constraints.MaxHeight);
        ToLeft(re, Constraints.MinWidth, Constraints.MaxWidth);
      end;
    dwpTopRight: begin
        ToTop(re, Constraints.MinHeight, Constraints.MaxHeight);
        ToRight(re, Constraints.MinWidth, Constraints.MaxWidth);
      end;
    dwpBottomLeft: begin
        ToBottom(re, Constraints.MinHeight, Constraints.MaxHeight);
        ToLeft(re, Constraints.MinWidth, Constraints.MaxWidth);
      end;
    dwpBottomRight: begin
        ToBottom(re, Constraints.MinHeight, Constraints.MaxHeight);
        ToRight(re, Constraints.MinWidth, Constraints.MaxWidth);
      end;
  end;
  _frm.BoundsRect := re;
end;

It’s already in the dzlib repository on sourceforge, unit u_dzVclUtils.

 Posted by on 2016-06-18 at 11:27