TCsvWriter added to dzlib

 Delphi, dzLib  Comments Off on TCsvWriter added to dzlib
Oct 102019
 

Yes, I know, there are many already existing solutions for writing a CSV file in Delphi. And some are probably better than mine (for general purpose usage), but those I looked at had too many shortcomings for my particular use case, so I wrote my own. (There might also have been some not invented here syndrome involved.)

Anyway: It’s now in my dzlib as u_dzCsvWriter and there are also unit tests for it.

Note that I have tested it only with Delphi 2007 so far (because I needed it for Delphi 2007). There might be Unicode related bugs that only surface in later versions.

 Posted by on 2019-10-10 at 11:50

Setting the drop down width of a Combobox in Delphi

 Delphi, dzLib  Comments Off on Setting the drop down width of a Combobox in Delphi
Jun 222019
 

By default, the width of the drop down list of a TComboBox is the same as the width of the control itself, and even in the latest Delphi version there apparently is no property to set it.

Why is that so? Good question. There are probably many third party controls that offer this because it is rather simple to implement. But on the other hand, if it is that simple, why isn’t it a feature of the default control? It can really be a pain in the lower back that some entries are just not displayed correctly as seen in the picture above.

Setting the drop down width is as simple as sending the CB_SETDROPPEDWIDTH message to the control’s handle:

SendMessage(TheCombobox.Handle, CB_SETDROPPEDWIDTH, MinimumWidthInPixels, 0);

It does not allow to shrink the width of the drop down list though, because it sets the minimum width, not the actual width. There is this answer on StackOverflow for that particular problem. The result isn’t very visually appealing though, because the list is left aligned rather than right.

Of course that can easily be fixed by adding the width difference to all coordinates passed to MoveWindow.

But the normal use case is probably that the list is not wide enough, not that it’s too wide.

While they help, these solutions still leave something to wish for: Usually you don’t want to set a fixed width in pixels, you want to make the drop down list wide enough so it fits the entries. So ideally you will take the list of entries, calculate their text width, optionally add the width of the scroll bar and set that as the width for the drop down list.

Of course, I am not the first one who want to do that. I found an ancient article by Zarko Gajic on ThoughtCo (formerly known as about.com) that deals with this issue. The result looks like this:

The article even goes a lot further. When do you call that code? Of course only after you added the items to the list. So, why not put it into the OnDropdown event of the ComboBox? (Because that clutters the sources and you also have to create an event handler for each of these ComboBoxes on your form, that’s why.). It also handles the case where the ComboBox is placed near the right border of the form and claims that it gets truncated there. I could not reproduce that problem. This looks fine to me:

So, why am I blogging about this? As said above, there are plenty of other articles on the web that handle these issues.

Last week I investigated several cases where the SendMessage code did not work at all. It turned out that somewhere between the SendMessage call in the form’s constructor and the time the user clicked the drop down button the window handle of the ComboBox got recreated, losing the changed drop down width. A solution for this would have been to put the code into the OnDropDown event. That would have required 4 event handlers, one for each of the ComboBoxes on that particular form, (or a shared event handler for all 4). I don’t like that, I prefer a solution that once and for all solves that problem by calling some function in the constructor and then forget about. So I went and wrote one:

// taken from:
// https://www.thoughtco.com/sizing-the-combobox-drop-down-width-1058301
// (previously about.com)
// by Zarko Gajic

procedure TComboBox_AutoWidth(_cmb: TCustomComboBox);
const
  HORIZONTAL_PADDING = 4;
var
  itemsFullWidth: Integer;
  Idx: Integer;
  itemWidth: Integer;
begin
  itemsFullWidth := 0;
  // get the max needed with of the items in dropdown state
  for Idx := 0 to -1 + _cmb.Items.Count do begin
    itemWidth := _cmb.Canvas.TextWidth(_cmb.Items[Idx]);
    Inc(itemWidth, 2 * HORIZONTAL_PADDING);
    if (itemWidth > itemsFullWidth) then
      itemsFullWidth := itemWidth;
  end;
  // set the width of drop down if needed
  if (itemsFullWidth > _cmb.Width) then begin
    //check if there would be a scroll bar
    if TComboBoxHack(_cmb).DropDownCount < _cmb.Items.Count then
      itemsFullWidth := itemsFullWidth + GetSystemMetrics(SM_CXVSCROLL);
    SendMessage(_cmb.Handle, CB_SETDROPPEDWIDTH, itemsFullWidth, 0);
  end;
end;

type
  TComboAutoWidthActivator = class(TWindowProcHook)
  protected
    procedure NewWindowProc(var _Msg: TMessage); override;
  public
    constructor Create(_cmb: TCustomComboBox);
  end;

{ TComboAutoWidthActivator }

constructor TComboAutoWidthActivator.Create(_cmb: TCustomComboBox);
begin
  inherited Create(_cmb);
end;

procedure TComboAutoWidthActivator.NewWindowProc(var _Msg: TMessage);
begin
  if _Msg.Msg = CBN_DROPDOWN then
    TComboBox_AutoWidth(TCustomComboBox(FCtrl));
  inherited;
end;

function TComboBox_ActivateAutoWidth(_cmb: TCustomComboBox): TObject;
begin
  Result := TComboAutoWidthActivator.Create(_cmb);
end;

The TCombobox_AutoWidth procedure is taken from Zarko Gajic’s article, but adapted to take a TCustomComboBox parameter rather than TComboBox (And while I am writing this I have got a few ideas what to improve on it.) The TComboAutoWidthActivator class is based on the TWindowProcHook class I used earlier. It simply hooks the control’s WindowProc, checks for the CBN_DROPDOWN message (which will later cause the OnDropDown event to be called) and calls TCombobox_AutoWidth.

So, my form’s contructor now looks like this:

constructor TMyForm.Create(_Owner: TComponent);
begin
  inherited;

  TCombobox_ActiveAutoWidth(cmb_One);
  TCombobox_ActiveAutoWidth(cmb_Two);
  TCombobox_ActiveAutoWidth(cmb_Three);
  TCombobox_ActiveAutoWidth(cmb_Four);
end;

Much cleaner than the solution with all those OnDropDown handlers.

The code above is part of u_dzVclUtils of my dzlib.

One possible improvement would be to have yet another function to enumerate over all controls on a form, find all ComboBoxes and call for them. I’m Not sure it’s worth the trouble, but it wouldn’t be rocket science either.

If you would like to comment on this article, go to this post in the international Delphi Praxis forum.

 Posted by on 2019-06-22 at 12:21

Autocompletion for TEdits revisited

 Delphi, dzLib  Comments Off on Autocompletion for TEdits revisited
Apr 282019
 

I wrote about autocompletion for TEdits before here and here.

Back then I was using the SHAutoComplete API function in the Shlwapi.dll because I am a lazy basterd™. That hasn’t changed really but I also love fiddling with stuff, so some years ago, I actually added directory and general string completion to dzlib (and apparently didn’t blog about it), this time using the IAutoComplete2 interface as described in this answer on StackOverflow, which I mentioned before.

Today I revisited that code and and added file and directory completion to it, in a way that also allows filtering the files with a given file mask. So the user can easily enter directories and eventually select a file:

To add this functionality to a TEdit control, one only needs to add the unit u_dzAutoCompleteFiles to the form and call TEdit_ActivateAutoCompleteFiles in the form’s constructor like this:

constructor Tf_AutoCompleteTest.Create(_Owner: TComponent);
begin
  inherited;
  TEdit_ActivateAutoCompleteFiles(ed_AutoCompleteFiles, '*.dfm');
end;

The magic happens in a helper class TEnumStringFiles derived from the same TEnumStringAbstract class as TEnumStringDirs and TEnumStringStringList, implementing the IEnumString interface. It implements three methods:

  • function Next(celt: LongInt; out elt; pceltFetched: PLongInt): HResult;
  • function Reset: HResult
  • function Skip(celt:LongInt): HResult;

Reset is called whenever Windows thinks it needs to get the autocompletion list. Basically that’s whenever the user presses the backslash key, but apparently there are also other events that trigger it. After that the functions Next and possibly Skip are called to get the actual list.

Since this class is supposed to return directories and files, it uses two instances of TSimpleDirectoryEnum which encapsulates SysUtils.FindFirst and SysUtils.FindNext. One is for directories the other is for files matching a given mask (actually “mask” is not quite the right word as the “mask” is always appended to the base string the user has entered).

Here is the complete unit (but you should really get the code from OSDN to make sure the get the latest version):

unit u_dzAutoCompleteFiles;

interface

uses
  Windows,
  Messages,
  SysUtils,
  Classes,
  StdCtrls,
  ActiveX,
  u_dzfileutils,
  i_dzAutoComplete;

type
  TOnGetBaseFileEvent = procedure(_Sender: TObject; out _Base: string) of object;

type
  ///<summary>
  /// Implementaition of IEnumString for files </summary>
  TEnumStringFiles = class(TEnumStringAbstract, IEnumString)
  private
    FOnGetBase: TOnGetBaseFileEvent;
    FDirEnum: TSimpleDirEnumerator;
    FFileEnum: TSimpleDirEnumerator;
    FBase: string;
    FFilter: string;
    procedure doOnGetBase(out _Base: string);
    function FindNextDirOrFile(out _DirOrFilename: WideString): Boolean;
  protected
    // IEnumString
    function Next(celt: Longint; out elt;
      pceltFetched: PLongint): HResult; override;
    function Skip(celt: Longint): HResult; override;
    function Reset: HResult; override;
  public
    constructor Create(_OnGetBase: TOnGetBaseFileEvent; const _Filter: string);
    destructor Destroy; override;
  end;

procedure TEdit_ActivateAutoCompleteFiles(_ed: TCustomEdit; const _Filter: string);

implementation

{ TEnumStringFiles }

constructor TEnumStringFiles.Create(_OnGetBase: TOnGetBaseFileEvent; const _Filter: string);
begin
  inherited Create;
  FFilter := _Filter;
  FOnGetBase := _OnGetBase;
end;

destructor TEnumStringFiles.Destroy;
begin
  FreeAndNil(FDirEnum);
  FreeAndNil(FFileEnum);
  inherited;
end;

procedure TEnumStringFiles.doOnGetBase(out _Base: string);
begin
  if Assigned(FOnGetBase) then
    FOnGetBase(Self, _Base);
end;

function TEnumStringFiles.FindNextDirOrFile(out _DirOrFilename: WideString): Boolean;
var
  fn: string;
begin
  if Assigned(FDirEnum) then begin
    Result := FDirEnum.FindNext(fn, True);
    if Result then begin
      _DirOrFilename := fn;
      Exit; //==>
    end;
  end;

  if Assigned(FFileEnum) then begin
    Result := FFileEnum.FindNext(fn, True);
    if Result then begin
      _DirOrFilename := fn;
      Exit; //==>
    end;
  end;
  Result := False;
end;

function TEnumStringFiles.Next(celt: Integer; out elt; pceltFetched: PLongint): HResult;
var
  i: Integer;
  wStr: WideString;
begin
  i := 0;
  while (i < celt) and FindNextDirOrFile(wStr) do begin
    TPointerList(elt)[i] := Pointer(wStr);
    Pointer(wStr) := nil;
    Inc(i);
  end;
  if pceltFetched <> nil then
    pceltFetched^ := i;
  if i = celt then
    Result := S_OK
  else
    Result := S_FALSE;
end;

function TEnumStringFiles.Reset: HResult;
begin
  doOnGetBase(FBase);
  FreeAndNil(FDirEnum);
  FreeAndNil(FFileEnum);
  FDirEnum := TSimpleDirEnumerator.CreateForDirsOnly(FBase + '*');
  FFileEnum := TSimpleDirEnumerator.CreateForFilesOnly(FBase + FFilter);
  Result := S_OK;
end;

function TEnumStringFiles.Skip(celt: Integer): HResult;
var
  i: Integer;
  wStr: WideString;
begin
  i := 0;
  while FindNextDirOrFile(wStr) do begin
    Inc(i);
    if i < celt then begin
      Result := S_OK;
      Exit; //==>
    end;
  end;
  Result := S_FALSE;
end;

type
  TAutoCompleteHelperFiles = class(TAutoCompleteHelper)
  private
    FFilter: string;
    procedure HandleOnGetBase(_Sender: TObject; out _Base: string);
  protected
    function CreateEnumStringInt: IEnumString; override;
  public
    constructor Create(_ed: TCustomEdit; const _Filter: string);
  end;

procedure TEdit_ActivateAutoCompleteFiles(_ed: TCustomEdit; const _Filter: string);
begin
  TAutoCompleteHelperFiles.Create(_ed, _Filter);
end;

{ TAutoCompleteHelperFiles }

constructor TAutoCompleteHelperFiles.Create(_ed: TCustomEdit; const _Filter: string);
begin
  FFilter := _Filter;
  inherited Create(_ed);
end;

function TAutoCompleteHelperFiles.CreateEnumStringInt: IEnumString;
begin
  Result := TEnumStringFiles.Create(HandleOnGetBase, FFilter);
end;

procedure TAutoCompleteHelperFiles.HandleOnGetBase(_Sender: TObject; out _Base: string);
begin
  _Base := (FCtrl as TCustomEdit).Text;
end;

end.

The code is in the newly added u_dzAutoCompleteFiles unit in my dzlib.

If you would like to comment on this, go to this post in the international Delphi Praxis forum.

 Posted by on 2019-04-28 at 18:41

Fake TSpeedButton based on a TBitBtn – updated

 Delphi, dzLib  Comments Off on Fake TSpeedButton based on a TBitBtn – updated
Jan 292018
 

I have made a few changes to the code in Fake TSpeedButton based on a TBitBtn:

  • I replaced all that line drawing with a call to the WinAPI function DrawEdge.
  • I set both bitmaps to Transparent.
  • I moved the bitmap generation to a sub procedure.

Thus I got rid of about 20 LOC. That’s negative productivity for you. 😉
(Which yet again shows that Lines Of Code is an idiotic metric for software developer productivity.)

The code has been tested with several Delphi versions (6, 7, 2007, XE2 and 10.2) in Windows 8.1 and is now used in the GExperts Rename Component Expert. There is no release yet, but you can always compile your own.

 Posted by on 2018-01-29 at 14:49

TdzStreamCache class for caching access to any TStream

 Delphi, dzLib  Comments Off on TdzStreamCache class for caching access to any TStream
Nov 252017
 

You might have noticed that I haven’t blogged as much as usual and that there have been no recent updates to GExperts either. The reason of course was that I was busy doing other things. Some of them were programming related and one of these was writing a caching class wrapper for TStream descendants (e.g. TFileStream, but it should work with any other streams as well).

It is simple to use and totally transparent to the calling code because the cache itself descends from TStream:

procedure TestCache;
var
  fs: TFileStream;
  cache: TdzStreamCache;
  i: integer;
  by: byte;
begin
  cache := nil;
  fs := TFileStream.Create('C:\test.dat', fmOpenWrite);
  try
    cache := TdzStreamCache.Create(fs);
    // now, do any operation you usually do on the stream, but use the
    // cache instead
    // e.g. write 50 megabytes of random bytes
    randomize;
    for i := 0 to 50*1024*1024 do begin
      by := Random(256);
      cache.WriteBuffer(by, SizeOf(by));
    end;
    // Writing a single byte to a TFileStream will result in very
    // bad performance, which is why we usually copy the bytes to a
    // larger buffer instead and then write this buffer to the stream.
    // Using the TdzStreamCache you won't see much of a difference between
    // these two approaches.
  finally
    FreeAndNil(cache);
    FreeAndNil(fs);
  end;
end;

TdzStreamCache can also be used for read and read/write access to a stream. It supports linear and also random access. Performance is worst when reading a stream backwards a single byte at a time.

To get an idea how well it performs, I have benchmarked it against David Heffernan‘s excellent CachedFileStream and found that it compares very well. (I could not simply use David’s class because I needed caching for other types of streams, not just files.)

I have been using TdzStreamCache extensively in the last several weeks and I am pretty sure that I have weeded out most of the bugs. But of course, that does not mean that there aren’t any left, so there are no guarantees. If you use it, all problems are your own.

TdzStreamCache is released under the Mozilla Public License (MPL) 1.1 as part of my dzLib library, but the unit is pretty much stand alone. The only thing it requires is jedi.inc because Delphi 2007 declares NativeInt inconsistently to other Delphi versions. As with all my dzlib code, it is available from sourceforge as u_dzStreamCache.pas.

The code for the benchmarks I mentioned above is also available if you want to do the benchmarks yourself.

I would appreciate any feed back, especially if you find bugs or improve on it.

 Posted by on 2017-11-25 at 22:16

Bugfix for the Build Connection String dialog appearing on the wrong monitor

 Delphi, dzLib  Comments Off on Bugfix for the Build Connection String dialog appearing on the wrong monitor
Apr 142017
 

According to MSDN the window handle passed to IDBPromptInitialize::PromptDataSource will be used this way:

hWndParent [in]
The parent window handle for dialog boxes to be displayed. The dialog box will always be centred within this window.

Unfortunately it doesn’t work like this: If the parent form is on a secondary monitor the dialog is shown on the primary monitor on the side adjacent to the secondary monitor. It works fine when the parent form is on the primary monitor.

This is the code I used:

class function TConnectionInfoRec.EditConnectionString(_ParentHandle: HWND;
  var _ConnectionString: string): Boolean;
var
  DataInit: IDataInitialize;
  DBPrompt: IDBPromptInitialize;
  DataSource: IUnknown;
  InitStr: PWideChar;
  s: WideString;
begin
  DataInit := CreateComObject(CLSID_DataLinks) as IDataInitialize;
  if _ConnectionString <> '' then begin
    s := _ConnectionString;
    DataInit.GetDataSource(nil, CLSCTX_INPROC_SERVER,
      PWideChar(s), IUnknown, DataSource);
  end;
  DBPrompt := CreateComObject(CLSID_DataLinks) as IDBPromptInitialize;
  Result := Succeeded(DBPrompt.PromptDataSource(nil, _ParentHandle,
    DBPROMPTOPTIONS_PROPERTYSHEET, 0, nil, nil, IUnknown, DataSource));
  if Result then begin
    InitStr := nil;
    DataInit.GetInitializationString(DataSource, True, InitStr);
    _ConnectionString := InitStr;
  end;
end;

Called as

procedure TForm1.b_TestClick(Sender: TObject);
var
  s: string;
begin
if  TConnectionInfoRec.EditConnectionString(Self.Handle, s) then
  ed_Result.Text := s;
end;

I asked on Google+ for help but nobody could find an error in my code, so it apparently is a bug in Windows.

So I set out to find a workaround: Start a background thread (since the foreground thread is blocked by showing that dialog) that finds the dialog and moves it to the correct place.

Unfortunately GetActiveWindow didn’t return this window, so I resorted to GetForegroundWindow and checked the window’s process id with GetThreadProcessId to make sure I got the correct window. While this worked, it left a bad smell. Using EnumThreadWindow as suggested by Attila Kovacs also worked, so I used that instead.

But while writing this blog post, I reread the GetActiveWindow documentation and noticed the reference to GetGUIThreadInfo which sounded as if it might do exactly what I was looking for. And lo and behold, it actually does. So here is the solution I eventually used:

type
  TMoveWindowThread = class(TNamedThread)
  private
    FParentHandle: HWND;
    FParentCenterX: Integer;
    FParentCenterY: Integer;
    procedure CenterWindow(wHandle: hwnd);
  protected
    procedure Execute; override;
  public
    constructor Create(_ParentHandle: HWND);
  end;

{ TMoveWindowThread }

constructor TMoveWindowThread.Create(_ParentHandle: HWND);
begin
  FreeOnTerminate := True;
  FParentHandle := _ParentHandle;
  inherited Create(False);
end;

procedure TMoveWindowThread.CenterWindow(wHandle: hwnd);
var
  Rect: TRect;
  WindowCenterX: Integer;
  WindowCenterY: Integer;
  MoveByX: Integer;
  MoveByY: Integer;
begin
  GetWindowRect(wHandle, Rect);
  WindowCenterX := Round(Rect.Left / 2 + Rect.Right / 2);
  WindowCenterY := Round(Rect.Top / 2 + Rect.Bottom / 2);
  MoveByX := WindowCenterX - FParentCenterX;
  MoveByY := WindowCenterY - FParentCenterY;
  MoveWindow(wHandle, Rect.Left - MoveByX, Rect.Top - MoveByY,
    Rect.Right - Rect.Left, Rect.Bottom - Rect.Top, False);
end;

procedure TMoveWindowThread.Execute;
var
  Rect: TRect;
  MaxTickCount: DWORD;
  ThreadInfo: TGUIThreadinfo;
begin
  inherited;
  GetWindowRect(FParentHandle, Rect);
  FParentCenterX := Round(Rect.Left / 2 + Rect.Right / 2);
  FParentCenterY := Round(Rect.Top / 2 + Rect.Bottom / 2);

  ThreadInfo.cbSize := SizeOf(ThreadInfo);
  MaxTickCount := GetTickCount + 10000; // 10 Seconds should be plenty
  while MaxTickCount > GetTickCount do begin
    Sleep(50);
    if GetGUIThreadInfo(MainThreadID, ThreadInfo) then begin
      if ThreadInfo.hwndActive <> FParentHandle then begin
        CenterWindow(ThreadInfo.hwndActive);
        Exit;
      end;
    end;
  end;
end;

This thread is started from EditConnectionString by inserting the following code:

  // ...
  DBPrompt := CreateComObject(CLSID_DataLinks) as IDBPromptInitialize;

  if _ParentHandle <> 0 then begin
    // This is a hack to make the dialog appear centered on the parent window
    // According to https://msdn.microsoft.com/en-us/library/ms725392(v=vs.85).aspx
    // the dialog should automatically be centered on the passed parent handle,
    // but if the parent window is not on the primary monitor this does not work.
    // So, we start a background thread that waits for the dialog to appear and then
    // moves it to the correct position.
    TMoveWindowThread.Create(_ParentHandle);
  end;

  Result := Succeeded(DBPrompt.PromptDataSource(nil, _ParentHandle,
    DBPROMPTOPTIONS_PROPERTYSHEET, 0, nil, nil, IUnknown, DataSource));
  // ...

Unfortunately the dialog briefly still appears in the wrong position. I found now way around that.

The code is in my dzlib library in unit u_dzConnectionString.

 Posted by on 2017-04-14 at 19:52

“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