mORMot Open Source

esmondb

Member

From: London

Registered: 2010-07-20

Posts: 299

LookupEdit instead of comboBox

TRecordEditForm in mORMotUIEdit.pas uses a combobox to select related TSQLRecord descendant fields in a record but this doesn't seem that scalable. Does anyone know of a good open source 'LookUp Edit' to use instead? I've had a go at writing one below but have a nasty feeling it's reinventing the wheel. (the code works but has barely been tested and is fairly crude)

unit FTSLookupEdit;

interface

uses
  Classes, StdCtrls, ExtCtrls, Messages, Controls, Windows, Forms,
  SysUtils, Graphics;

type
  TFTSLookupEdit = class;

  TFTSPopupList = class;

  TFTSTickMark = class;

  TIDLabel = class;

  TResultIDs = array of integer;

  TLookUpEvent = procedure(Sender: TFTSLookupEdit;
                           Search: string;
                           MaxResults: integer;
                           var IDs: TResultIDs;  //IDs must match ResultStrings size
                           ResultStrings: TStrings) of object;

  TFTSLookupEdit = class(TCustomLabeledEdit)
  private
    fListbox: TFTSPopupList;
    fTickMark: TFTSTickMark;
    fRecordNumberLabel: TIDLabel;
    fDropDownLineCount: integer;
    fMaxResults: integer;
    fResultIDs: TResultIDs;
    fSelectedID: integer;
    fShowID: boolean;
    fShowTick: boolean;
    fLastSearch: string;
    procedure ShowDropDown;
    procedure HideDropDown;
    procedure SetTickPosition;
    procedure SetListBoxPosition;
    procedure SetRecordNumberLabelPosition;
    procedure SetChildPositions;
    procedure SetRecordFromListbox;
    procedure SetID(ID: integer);
    procedure WMSize(var Message: TWMSize); message WM_SIZE;
    procedure WMKillFocus(var Message: TWMKillFocus); message WM_KILLFOCUS;
    procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
    procedure CMCancelMode(var Message: TCMCancelMode); message CM_CANCELMODE;
  protected
    fOnLookUp: TLookUpEvent;
    fOnChangedID: TNotifyEvent;
    procedure SetParent(AParent: TWinControl); override;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    procedure KeyPress(var Key: Char); override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
       X, Y: Integer); override;
    procedure Change; override;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure CMBidimodechanged(var Message: TMessage); message CM_BIDIMODECHANGED;
    procedure CMVisiblechanged(var Message: TMessage); message CM_VISIBLECHANGED;
  public
    constructor Create(AOwner: TComponent); override;
    procedure SetBounds(ALeft: integer; ATop: integer; AWidth: integer; AHeight: integer); override;
    function Focused: Boolean; override;
    property SelectedID: integer read fSelectedID write SetID;
  published
    property DropDownLineCount: integer read fDropDownLineCount write fDropDownLineCount default 8;
    property MaxResults: integer read fMaxResults write fMaxResults default 32;
    property OnLookUp: TLookUpEvent read fOnLookUp write fOnLookUp;
    property OnChangedID: TNotifyEvent read fOnChangedID write fOnChangedID;
    property ShowID: boolean read fShowID write fShowID default true;
    property ShowTick: boolean read fShowTick write fShowTick default true;
    // Inherited properties
    property Anchors;
    property Color;
    property Constraints;
    property Ctl3D;
    property DragCursor;
    property DragMode;
    property Enabled;
    property Font;
    property ImeMode;
    property ImeName;
    property Name;
    property ParentColor;
    property ParentCtl3D;
    property ParentFont;
    property ParentShowHint;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property Visible;
    property EditLabel;
    // Inherited events
    property OnChange;
    property OnClick;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnStartDrag;
  end;

  TFTSPopupList = class(TCustomListBox)
  private
    fLookUpOwner: TFTSLookupEdit;
    fDefaultWindowProc: TWndMethod;
  protected
    procedure CreateParams(var Params: TCreateParams); override;
    procedure PopupListWindowProc(var Message: TMessage);
  public
    constructor Create(AOwner: TComponent); override;
  end;

  TFTSTickMark = class(TGraphicControl)
  private
    fBitmap: TBitmap;
  protected
    procedure Paint; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  end;

  TIDLabel = class(TCustomLabel)
  protected
    procedure AdjustBounds; override;
  public
    constructor Create(AOwner: TComponent); override;
  end;

procedure Register;

implementation

{$R *.RES}

constructor TFTSLookupEdit.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Height := 21;
  fListbox := TFTSPopupList.Create(self);
  fListbox.Parent := self;
  fSelectedID := 0;
  fShowID := True;
  fShowTick := True;
  fDropDownLineCount := 8;
  fMaxResults := 32;
  fLastSearch := '';
  fTickMark := TFTSTickMark.Create(self);
  fTickMark.Parent := self;
  fTickMark.FreeNotification(Self);
  fRecordNumberLabel := TIDLabel.Create(Self);
  fRecordNumberLabel.Parent := self;
  fRecordNumberLabel.FreeNotification(Self);
  fRecordNumberLabel.FocusControl := Self;
  fRecordNumberLabel.Caption := '';
end;

procedure TFTSLookupEdit.SetParent(AParent: TWinControl);
begin
  inherited SetParent(AParent);
  if fTickMark <> nil then
    fTickMark.Parent := AParent;
  if fListbox <> nil then
    fListbox.Parent := AParent;
  if fRecordNumberLabel <> nil then
    fRecordNumberLabel.Parent := AParent;
end;

procedure TFTSLookupEdit.SetTickPosition;
begin
  if fTickMark <> nil then
    fTickMark.SetBounds(Left + Width - 18, Top - 18, 16, 16);
end;

procedure TFTSLookupEdit.SetListBoxPosition;
var
  P: TPoint;
  ListHeight: Integer;
begin
  if (fListBox <> nil) and (Parent <> nil) then begin
    P := parent.ClientOrigin;
    if fListbox.Items.Count < fDropDownLineCount then
      ListHeight := (fListbox.Items.Count * FListBox.ItemHeight) +2
    else
      ListHeight := (fDropDownLineCount * FListBox.ItemHeight) +2;
    if (Top + P.Y + Height + ListHeight) > Screen.WorkAreaHeight then
      fListbox.SetBounds(Left + P.X, Top + P.Y - ListHeight, Width, ListHeight)
    else
      fListbox.SetBounds(Left + P.X, Top + P.Y + Height, Width, ListHeight);
  end;
end;

procedure TFTSLookupEdit.SetRecordNumberLabelPosition;
begin
  if fRecordNumberLabel = nil then Exit;
  //should look at position option. for now just puts it top right
  fRecordNumberLabel.SetBounds(Left + Width - fRecordNumberLabel.Width - 20,
    Top - fRecordNumberLabel.Height - LabelSpacing,
    fRecordNumberLabel.Width, fRecordNumberLabel.Height);
end;

procedure TFTSLookupEdit.SetChildPositions;
begin
  SetTickPosition;
  SetListBoxPosition;
  SetRecordNumberLabelPosition;
end;

procedure TFTSLookUpEdit.SetRecordFromListbox;
var
  NewID: integer;
begin
  if fListBox.ItemIndex > -1 then begin
    NewID := fResultIDs[fListBox.ItemIndex];
    if Text <> fListBox.Items.Strings[fListBox.ItemIndex] then begin
      Text := fListBox.Items.Strings[fListBox.ItemIndex];
      SelStart := length(Text);
      SelLength := 0;
    end;
    fListBox.Items.Clear;
    SetLength(fResultIDs, 0);
  end else
    NewID := 0;
  if NewID <> fSelectedID then begin
    fSelectedID := NewID;
    if NewID > 0 then begin
      if fShowID then
        fRecordNumberLabel.Caption := inttostr(NewID);
      if fShowTick then
        fTickMark.Visible := True;
    end else begin
      fTickMark.Visible := False;
      fRecordNumberLabel.Caption := '';
    end;
    if assigned(fOnChangedID) then
      fOnChangedID(self);
  end;
end;

procedure TFTSLookUpEdit.SetID(ID: integer);
begin
  fSelectedID := ID;
  fTickMark.Visible := ID > 0;
  if fShowID then
    fRecordNumberLabel.Caption := inttostr(ID);
end;

procedure TFTSLookupEdit.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
begin
  inherited SetBounds(ALeft, ATop, AWidth, AHeight);
  SetChildPositions;
end;

function TFTSLookupEdit.Focused: Boolean;
var
  FocusedWnd: HWND;
begin
  Result := False;
  if HandleAllocated = true then begin
    FocusedWnd := GetFocus;
    Result := (FocusedWnd = fListbox.Handle) or (FocusedWnd = Handle);
  end;
end;

procedure TFTSLookupEdit.ShowDropDown;
begin
  if fListbox.Items.Count > 0 then begin
    SetListBoxPosition;
    fListbox.visible := true;
    if fListbox.ItemIndex = -1 then
      fListbox.ItemIndex := 0;
  end else
    fListbox.Visible := false;
end;

procedure TFTSLookupEdit.HideDropDown;
begin
  fListbox.visible := false;
end;

procedure TFTSLookupEdit.WMSize(var Message: TWMSize);
begin
  inherited;
  SetChildPositions;
end;

procedure TFTSLookupEdit.WMKillFocus(var Message: TWMKillFocus);
begin
  if not Focused then HideDropDown;
  inherited;
end;

procedure TFTSLookupEdit.CMCancelMode(var Message: TCMCancelMode);
begin
  if (Message.Sender <> Self) and (Message.Sender <> FListBox) then
    HideDropDown;
end;

procedure TFTSLookupEdit.KeyDown(var Key: Word; Shift: TShiftState);
begin
  case Key of
    VK_ESCAPE: HideDropDown;
    VK_UP:     if not fListBox.Visible then
                 ShowDropDown
               else if fListBox.ItemIndex > 0 then
                 fListBox.ItemIndex := fListBox.ItemIndex -1;
    VK_DOWN:   if not fListBox.Visible then
                 ShowDropDown
               else if (fListBox.Items.Count > 0) and
                (fListBox.ItemIndex < fListBox.Items.Count -1) then
                 fListBox.ItemIndex := fListBox.ItemIndex +1;
    VK_HOME:   if fListBox.Items.Count > 0 then
                 fListBox.ItemIndex := 0;
    VK_END:    if fListBox.Items.Count > 0 then
                 fListBox.ItemIndex := fListBox.Items.Count -1;
    VK_RETURN: if fListBox.Visible then begin
                 SetRecordFromListbox;
                 HideDropDown;
               end else
                 inherited KeyDown(Key, Shift);
    VK_TAB:    HideDropDown;
    else begin
      inherited KeyDown(Key, Shift);
      exit;
    end;
  end;
  Key := 0;
end;

procedure TFTSLookupEdit.KeyPress(var Key: Char);
begin
  if Key in [#13,#27] then Key := #0
  else inherited KeyPress(Key);
end;

procedure TFTSLookupEdit.MouseDown(Button: TMouseButton; Shift: TShiftState;
       X, Y: Integer);
begin
  if fListbox.Visible then fListbox.Visible := false
  else ShowDropDown;
  inherited MouseDown(Button, Shift, X, Y);
end;

procedure TFTSLookupEdit.Change;
var
  i, ii, listCnt: integer;
  s : string;
begin
  if Modified = true then begin
    s := lowercase(Text);
    fListbox.Items.BeginUpdate;
    if (fLastSearch <> '') and (pos(fLastSearch, Text) > 0) and (fListbox.Count < fMaxResults) then begin
      //local filter - may not completely match remote query.
      listCnt := fListbox.Count;
      for i := listCnt -1 downto 0 do
        if pos(s,lowercase(fListbox.Items.Strings[i])) = 0 then begin
          fListbox.Items.Delete(i);
          for ii := i to fListbox.Count-1 do
            fResultIDs[ii] := fResultIDs[ii+1];
        end;
      SetLength(fResultIDs,fListbox.Count);
    end else if assigned(fOnLookUp) then begin
      fListbox.Clear;
      fOnLookUp(self, Text, fMaxResults, fResultIDs, fListbox.Items)
    end;
    fListbox.Items.EndUpdate;
    i := fListbox.Items.IndexOf(Text);
    if i > -1 then begin
      fListbox.ItemIndex := i;
      SetRecordFromListbox;
    end else begin
      fRecordNumberLabel.Caption := '';
      fTickMark.Visible := False;
      if fSelectedID <> 0 then begin
        fSelectedID := 0;
        if assigned(fOnChangedID) then
          fOnChangedID(self);
      end;
      if (fListbox.Items.Count > 0) and (fListbox.ItemIndex = -1) then
        fListbox.ItemIndex := 0;
    end;
    ShowDropDown;
    fLastSearch := Text;
  end;
  inherited Change;
end;

procedure TFTSLookupEdit.CMBidimodechanged(var Message: TMessage);
begin
  inherited;
  if fRecordNumberLabel <> nil then
    fRecordNumberLabel.BiDiMode := BiDiMode;
end;

procedure TFTSLookupEdit.CMEnabledchanged(var Message: TMessage);
begin
  inherited;
  if fRecordNumberLabel <> nil then
    fRecordNumberLabel.Enabled := Enabled;
end;

procedure TFTSLookupEdit.CMVisiblechanged(var Message: TMessage);
begin
  inherited;
  if fTickMark <> nil then
    //ControlStyle := ControlStyle + [csNoDesignVisible];
    if fShowTick then
      fTickMark.Visible := Visible;
    //else
      //fTickMark.Visible := False;
  if fRecordNumberLabel <> nil then
    if fShowID then
      fRecordNumberLabel.Visible := Visible;
  if fListBox <> nil then
    if not visible then
      fListBox.Visible := Visible;
end;

procedure TFTSLookupEdit.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if (AComponent = fTickMark) and (Operation = opRemove) then
    fTickMark := nil;
  if (AComponent = fListBox) and (Operation = opRemove) then
    fListBox := nil;
  if (AComponent = fRecordNumberLabel) and (Operation = opRemove) then
    fRecordNumberLabel := nil;
end;

{-------------}
{TFTSPopupList}
{-------------}

constructor TFTSPopupList.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  fLookUpOwner := TFTSLookupEdit(AOwner);
  AutoComplete := False;
  Ctl3D := False;
  TabStop := False;
  self.BorderStyle := bsNone;
  fDefaultWindowProc := self.WindowProc;
  self.WindowProc := PopupListWindowProc;
  ControlStyle := ControlStyle + [csNoDesignVisible];
  Visible := false;
end;

procedure TFTSPopupList.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  with Params do begin
    Style := Style or WS_POPUP or WS_BORDER;
    if CheckWin32Version(5, 1) then
      WindowClass.Style := WindowClass.style or CS_SAVEBITS or CS_DROPSHADOW
    else
      WindowClass.Style := WindowClass.Style or CS_SAVEBITS;
    if NewStyleControls then
      ExStyle := ExStyle or WS_EX_NOACTIVATE or WS_EX_TOOLWINDOW;//WS_EX_TOPMOST
    AddBiDiModeExStyle(ExStyle);
  end;
end;

procedure TFTSPopupList.PopupListWindowProc(var Message: TMessage);
var
  P: TPoint;
begin
  case Message.Msg of
    WM_MOUSEMOVE:           begin
                              P := Point(Message.LParamLo, Message.LParamHi);
                              if BiDiMode = bdRightToLeft then
                                P.X := - P.X;
                              self.ItemIndex := self.ItemAtPos(P,true);
                              Message.Result := 0;
                            end;
    WM_LBUTTONDOWN:         begin
                              fLookUpOwner.SetRecordFromListbox;
                              fLookUpOwner.HideDropDown;
                              Message.Result := 0;
                            end;
    WM_LBUTTONDBLCLK:       fLookUpOwner.HideDropDown;
    WM_LBUTTONUP, WM_RBUTTONDOWN..WM_MOUSELAST: Message.Result := 0;
    WM_ACTIVATE:            Message.Result := 0;
    WM_SETCURSOR:           Message.Result := 1;
    WM_MOUSEACTIVATE:       Message.Result := MA_NOACTIVATE;
    else
      fDefaultWindowProc(Message);
  end;
end;

{------------}
{TFTSTickMark}
{------------}

constructor TFTSTickMark.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  fBitmap := TBitmap.Create;
  if FindResource(HInstance, pchar('TICKMARK'), RT_BITMAP) <> 0 then
    fBitmap.LoadFromResourceName(HInstance, 'TICKMARK')
  else begin
    fBitmap.Width := 16;
    fBitmap.Height := 16;
    fBitmap.Canvas.MoveTo(0,12);
    fBitmap.Canvas.LineTo(4,16);
    fBitmap.Canvas.LineTo(16,0);
  end;
  fBitmap.Transparent := true;
  Height := 16;
  Width := 16;
  Name := 'SubTick';
  Visible := False;
end;

destructor TFTSTickMark.Destroy;
begin
  fBitmap.Free;
  inherited Destroy;
end;

procedure TFTSTickMark.Paint;
begin
  with inherited Canvas do
    Draw(0,0, fBitmap);
end;

{--------}
{TIDLabel}
{--------}

constructor TIDLabel.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Name := 'SubIDLabel';
end;

procedure TIDLabel.AdjustBounds;
begin
  inherited AdjustBounds;
  if height < 16 then //reserve space for top tick when top aligned
    height := 16;
  if Owner is TFTSLookupEdit then
    with Owner as TFTSLookupEdit do
      SetRecordNumberLabelPosition;
end;

procedure Register;
begin
   RegisterComponents('Additional', [TFTSLookupEdit]);
end;

end.

ab

Administrator

From: France

Registered: 2010-06-21

Posts: 14,661

Website

Re: LookupEdit instead of comboBox

I'm not an expert about VCL controls, but your attempt sounds just successful...

I've found that CB_FINDSTRING is also simple to use.
See http://msdn.microsoft.com/en-us/library … s.85).aspx
and http://www.delphidabbler.com/tips/110 or http://delphi.longzu.net//viewthread.php?tid=48921