TACComboBox

unit Unit1;

{$mode objfpc}{$H+}


interface

uses
  Classes, SysUtils, Forms, Controls, Graphics, Dialogs, LMessages, StdCtrls,
  Messages, LCLType, LCLIntf, Variants;

type // Класс, реализующий выпадающее окно автозавершения

  { TDropDownListBox }

  TDropDownListBox = class(TListBox)
  protected
    procedure WMActivateApp(var M: TMessage); message WM_ACTIVATEAPP;
    procedure WMMouseMove(var M: TLMMouseMove); message WM_MOUSEMOVE;
    procedure WMLButtonUp(var M: TLMLButtonUp); message WM_LBUTTONUP;
    procedure CreateParams(var Params: TCreateParams); override;
    procedure UpdateItemIndex;
  end;

type
  TCheckStringEvent = procedure(Sender: TObject; const EditText, S: String; var AddString: Boolean) of object;

type
  TAutoCompleteType = (actSimple, actSubString, actCustom);

type // Комбо-бокс с выпадающем окном автозавершения

  { TACComboBox }

  TACComboBox = class(TComboBox)

    private
      FACItems : TStrings;
      FOldFormWndProc, FNewFormWndProc: Pointer; // Используется для подмены оконной процедуры родительской формы
      FParentFormWnd: hWnd; // Handle родительской формы
      FDropped: Boolean; // True, когда показано выпадающее окно
      FACType: TAutoCompleteType;
      FOnCheckString : TCheckStringEvent;
      procedure SetACItems ( AValue : TStrings ) ;
    protected
      FDropDown: TDropDownListBox; // Выпадающее окно автозавершения
      procedure SetParent(AParent: TWinControl); override;
      procedure ParentFormWndProc(var Message: TMessage);  // Оконная процедура, которой подменяем оконную процедуру родительской формы
    public
      constructor Create(AOwner: TComponent); override;
      destructor Destroy; override;
    published
      property ACItems: TStrings read FACItems write SetACItems;
      property ACType: TAutoCompleteType read FACType write FACType default actSubString;
      property OnCheckString: TCheckStringEvent read FOnCheckString write FOnCheckString;
  end;

type

  { TForm1 }

  TForm1 = class ( TForm )
    ListBox1 : TListBox;
    procedure FormCreate ( Sender : TObject ) ;
  private

  public

  end;

var
  Form1 : TForm1;
  CA : TACComboBox;

implementation

{$R *.lfm}

{ TForm1 }

procedure TForm1.FormCreate ( Sender : TObject ) ;
begin
  CA := TACComboBox.Create(Self);
  CA.Parent := Self;
  CA.Align := alTop;


end;

{ TDropDownListBox }

procedure TDropDownListBox.WMActivateApp ( var M : TMessage ) ;
begin

end;

procedure TDropDownListBox.WMMouseMove ( var M : TLMMouseMove ) ;
begin

end;

procedure TDropDownListBox.WMLButtonUp ( var M : TLMLButtonUp ) ;
begin

end;

procedure TDropDownListBox.CreateParams ( var Params : TCreateParams ) ;
begin
  inherited CreateParams ( Params ) ;
  Params.ExStyle := WS_EX_TOOLWINDOW;
  Params.WndParent := GetDC(0);
  Params.Style := WS_CHILD or WS_BORDER or WS_CLIPSIBLINGS or WS_OVERLAPPED or WS_VSCROLL or LBS_NOINTEGRALHEIGHT;
end;

procedure TDropDownListBox.UpdateItemIndex;
begin

end;

{ TACComboBox }

constructor TACComboBox.Create ( AOwner : TComponent ) ;
  var
    H : HWND;
    F : TCustomForm;
begin
  inherited Create ( AOwner ) ;
  FACItems := TStringList.Create;
  FACType := actSubString;
  FDropped := False;
  FParentFormWnd := 0;

  if not (csDesigning in ComponentState) then
    begin
      FDropDown := TDropDownListBox.Create(Self);
      //F := GetParentForm(AOwner as TControl);
      //FDropDown.Parent := Self;
      //ShowMessage(VarToStr(F.Name));
      //FDropDown.Left := 10; // Например, установка координат
      //FDropDown.Top := 10;
      ////FDropDown.Width := 100;
      //FDropDown.Height := 80;
      //if Assigned(FDropDown) then
      //  begin
      //    FDropDown.CreateWnd;
      //    ShowMessage(IntToStr(FDropDown.Handle));
      //  end;

      Exit;

      // Теперь вы можете безопасно обращаться к Handle
      // Например,
      ShowMessage(IntToStr(FDropDown.Handle));



      //SetWindowLong(FDropDown.Handle, GWL_HWNDPARENT, GetDC(0));
      H := FDropDown.Handle;
      ShowWindow(FDropDown.Handle, SW_SHOW);
    end;
end;

destructor TACComboBox.Destroy;
begin
  if not (csDesigning in ComponentState) then FDropDown.Free;
  FACItems.Free;
  inherited Destroy;
end;

procedure TACComboBox.SetACItems ( AValue : TStrings ) ;
begin
  if FACItems = AValue then Exit;
  FACItems := AValue;
end;

procedure TACComboBox.ParentFormWndProc ( var Message : TMessage ) ;
  procedure Default;
  begin
    with Message do Result := CallWindowProc(FOldFormWndProc, FParentFormWnd, Msg, wParam, lParam);
  end;
begin
  //case Message.Msg of // при изменении положения родительской формы прячем окно автозавершения
  //  WM_WINDOWPOSCHANGING, WM_WINDOWPOSCHANGED: ;//HideAC(False);
  //end; // case
  Default;
end;

procedure TACComboBox.SetParent ( AParent : TWinControl ) ;
  var
    Frm : TCustomForm;
begin
  // Если вдруг (что маловероятно :)) компонент переносится с одной формы на другую,
  // возвращаем форме ее "родную" оконную процедуру
  if not (csDesigning in ComponentState) and (FParentFormWnd <> 0) then
    SetWindowLong(FParentFormWnd, GWL_WNDPROC, Integer(FOldFormWndProc));

  inherited SetParent ( AParent ) ;

  // Подменяем оконную процедуру родительской формы. Делаем это только в Run-Time,
  // т.к. в Design-Time список автозавершения не создается
  if not (csDesigning in ComponentState) then
    begin
      Frm := GetParentForm(Self);
      if Assigned(Frm) then
    begin
      FParentFormWnd := Frm.Handle;
      FNewFormWndProc := MakeObjectInstance(@ParentFormWndProc);
      FOldFormWndProc := Pointer(GetWindowLong(FParentFormWnd, GWL_WNDPROC));
      SetWindowLong(FParentFormWnd, GWL_WNDPROC, Integer(FNewFormWndProc));
    end;
    end;
end;

end.