unit PickStringList;

interface

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

type
	TPaintItemProc = procedure(aValue: string; aCanvas: TCanvas; aRect: TRect;
		aState: TOwnerDrawState) of object;
	TPickListBox = class(TListBox)
	private
		procedure CloseUp(aModalResult: TModalResult);

	public
		FPaintItem: TPaintItemProc;

		procedure KeyDown(var aKey: Word; aShift: TShiftState); override;
		procedure MouseUp(aButton: TMouseButton; aShift: TShiftState; aX, aY: Integer); override;
		procedure MouseMove(aShift: TShiftState; aX, aY: Integer); override;
		procedure KillFocus(var aMsg: TWMKillFocus); message WM_KILLFOCUS;
		procedure CNDrawItem(var aMsg: TWMDrawItem); message CN_DRAWITEM;
	end;

	TPickListForm = class(TForm)
	public
		ListBox: TPickListBox;
		PopupMenu: TPopupMenu;

		constructor Create(anOwner: TComponent); override;
		procedure CreateParams(var aParams: TCreateParams); override; 
		procedure AlignControls(aControl: TControl; var aR: TRect); override;
		procedure PopupCancelClick(Sender: TObject);
		procedure Paint; override;
	end;


function PickFromList(aR: TRect; var s: string; aStrings: TStrings;
	aPaintItem: TPaintItemProc): Boolean;
function PickFromDropdownList(aR: TRect; aStrings: TStrings;
	aPaintItem: TPaintItemProc; var anIndex: Integer): Boolean;

implementation

procedure TPickListBox.CloseUp(aModalResult: TModalResult);
begin
	ValidParentForm(Self).ModalResult := aModalResult;
	PostMessage(ValidParentForm(Self).Handle, WM_CLOSE, 0, 0);
end;

procedure TPickListBox.KeyDown(var aKey: Word; aShift: TShiftState);
begin
	case aKey of
		VK_ESCAPE:
			CloseUp(mrCancel);
		VK_SPACE,
		VK_RETURN:
			CloseUp(mrOk);
		VK_UP,
		VK_DOWN:
			if ssAlt in aShift then
				CloseUp(mrOk)
			else
				Exit;
		else
			Exit
	end;
	aKey := 0;
end;

procedure TPickListBox.KillFocus(var aMsg: TWMKillFocus);
begin
	if ValidParentForm(Self).ModalResult = 0 then
		CloseUp(mrCancel);
end;

procedure TPickListBox.MouseUp(aButton: TMouseButton; aShift: TShiftState; aX, aY: Integer);
begin
	CloseUp(mrOk);
end;

procedure TPickListBox.MouseMove(aShift: TShiftState; aX, aY: Integer);
begin
	ItemIndex := ItemAtPos(Point(aX, aY), True);
end;

procedure TPickListBox.CNDrawItem(var aMsg: TWMDrawItem);
var
	aData: PDrawItemStruct;
	aState: TOwnerDrawState;
	r: TRect;
begin
	aData := aMsg.DrawItemStruct;
	aState := TOwnerDrawState(LongRec(aData.ItemState).Lo);
	Canvas.Handle := aData.hDC;
	Canvas.Font := Font;
	Canvas.Brush := Brush;
	Canvas.Pen.Style := psSolid;
	r := aData.rcItem;
	if (Integer(aData.ItemID) >= 0) then begin
		if Assigned(FPaintItem) then begin
			if (odSelected in aState) then
				Frame3D(Canvas, r, clHighlight, clHighlight, 1)
			else
				Frame3D(Canvas, r, Color, Color, 1);
			Frame3D(Canvas, r, Color, Color, 2);
			FPaintItem(Items[aData.ItemID], Canvas, r, aState)
		end
		else begin
			if (odSelected in aState) then begin
				Canvas.Brush.Color := clHighlight;
				Canvas.Font.Color := clHighlightText;
			end;
			InflateRect(r, -1, -1);
			Inc(r.Bottom, 2);
			Canvas.TextRect(r, r.Left + 4, r.Top + 1, Items[aData.ItemID]);
		end
	end
	else
		Canvas.FillRect(aData.rcItem);
	Canvas.Handle := 0;
end;

////////////////////////////////////////////////////////////////////////////////
//	TPickListForm
//
constructor TPickListForm.Create(anOwner: TComponent);
begin
	inherited CreateNew(anOwner, 0);
	BorderStyle := bsNone;
	ListBox := TPickListBox.Create(Self);
	with ListBox do begin
		Align := alClient;
		Left := 0;
		Top := 0;
		Width := 1;
		Height := 1;
		BorderStyle := bsNone;
		Name := 'ListBox';
		Parent := Self;
		Ctl3D := False;
		ParentColor := True;
	end;
	ActiveControl := ListBox;
end;

procedure TPickListForm.CreateParams(var aParams: TCreateParams);
begin
	inherited;
	aParams.WindowClass.style := aParams.WindowClass.style or CS_SAVEBITS;
	aParams.ExStyle := aParams.ExStyle or WS_EX_TOPMOST;
end;

procedure TPickListForm.AlignControls(aControl: TControl; var aR: TRect);
begin
	if ListBox <> nil then begin
		InflateRect(aR, -2, -2);
		with ListBox do begin
			Left := aR.Left;
			Top := aR.Top;
			Width := aR.Right - aR.Left;
			Height := aR.Bottom - aR.Top
		end;
	end
end;

procedure TPickListForm.PopupCancelClick(Sender: TObject);
begin
	ModalResult := mrCancel;
end;

procedure TPickListForm.Paint;
var
	aR: TRect;
begin
	aR := ClientRect;
	DrawEdge(Canvas.Handle, aR, EDGE_RAISED, BF_RECT)
end;

////////////////////////////////////////////////////////////////////////////////
//  functions
//

function GetWorkArea: TRect;
begin
	SystemParametersInfo(SPI_GETWORKAREA, 0, @Result, 0);
end;

procedure GetMaxWidthHeight(aMinWidth: Integer; aFont: TFont; aStrings: TStrings;
	var	aMaxWidth, aMaxHeight: Integer);
var
	i: Integer;
	aCanvas: TCanvas;
	aSize: TSize;
begin
	aCanvas := TCanvas.Create;
	try
		aCanvas.Handle := GetDC(0);
		aCanvas.Font := aFont;
		aMaxWidth := aMinWidth;
		aMaxHeight := 10;
		for i := 0 to aStrings.Count - 1 do begin
			aSize := aCanvas.TextExtent(aStrings[i]);
			if aSize.cx + 16 > aMaxWidth then
				aMaxWidth := aSize.cx + 16;
			if aSize.cy + 4 > aMaxHeight then
				aMaxHeight := aSize.cy + 4;
		end;
	finally
		aCanvas.Free;
	end;
end;

procedure CorrectPlace(var aR: TRect);
var
	aScreen: TRect;
begin
	aScreen := GetWorkArea;
	if aR.Right > aScreen.Right then
		OffsetRect(aR, aScreen.Right - aR.Right, 0);
	if aR.Left < aScreen.Left then
		OffsetRect(aR, aScreen.Left - aR.Left, 0);

	if aR.Bottom > aScreen.Bottom then
		OffsetRect(aR, 0, aScreen.Bottom - aR.Bottom);
	if aR.Top < aScreen.Top then
		OffsetRect(aR, 0, aScreen.Top - aR.Top);
end;

procedure GetBottomPlace(
	aX, aY, anItemHeight, anItemWidth, anItemCount: Integer;
	var aCount: Integer;
	var aR: TRect);
var
	aScreen: TRect;
begin
	aScreen := GetWorkArea;
	aR.Right := aX;
	aR.Left := aX - anItemWidth;
	aR.Top := aY;
	aCount := (aScreen.Bottom - aY - 4) div anItemHeight;
	if aCount > anItemCount then
		aCount := anItemCount;
	aR.Bottom := aR.Top + aCount * anItemHeight + 4;
	CorrectPlace(aR);
end;

procedure GetTopPlace(
	aX, aY, anItemHeight, anItemWidth, anItemCount: Integer;
	var aCount: Integer;
	var aR: TRect);
var
	aScreen: TRect;
begin
	aScreen := GetWorkArea;
	aR.Right := aX;
	aR.Left := aX - anItemWidth;
	aR.Bottom := aY;
	aCount := (aY - aScreen.Top - 4) div anItemHeight;
	if aCount > anItemCount then
		aCount := anItemCount;
	aR.Top := aR.Bottom - aCount * anItemHeight + 4;
	CorrectPlace(aR);
end;

function PickFromList(aR: TRect; var s: string; aStrings: TStrings;
	aPaintItem: TPaintItemProc): Boolean;
var
	anIndex: Integer;
begin
	anIndex := aStrings.IndexOf(s);
	Result := PickFromDropdownList(aR, aStrings, aPaintItem, anIndex);
	if Result and (anIndex >= 0) and (anIndex < aStrings.Count) then
		s := aStrings[anIndex];
end;

function PickFromDropdownList(aR: TRect; aStrings: TStrings;
	aPaintItem: TPaintItemProc; var anIndex: Integer): Boolean;
var
	aTopCount,
	aBottomCount,
	aMaxWidth, aMaxHeight: Integer;
	aTopR,
	aBottomR: TRect;
	aForm: TPickListForm;
begin
	aForm := TPickListForm.Create(Application);
	with aForm do begin
		ListBox.FPaintItem := aPaintItem;
		ListBox.Items := aStrings;
		ListBox.ItemIndex := anIndex;

		ListBox.Style := lbOwnerDrawFixed;
		ListBox.ItemHeight := 20;
		if Assigned(aPaintItem) then
			aMaxWidth := aR.Right - aR.Left
		else begin
			GetMaxWidthHeight(aR.Right - aR.Left, ListBox.Font, aStrings,
				aMaxWidth, aMaxHeight);
			ListBox.ItemHeight := aMaxHeight
		end;

		GetTopPlace(aR.Right, aR.Top, ListBox.ItemHeight, aMaxWidth, aStrings.Count, aTopCount, aTopR);
		GetBottomPlace(aR.Right, aR.Bottom, ListBox.ItemHeight, aMaxWidth, aStrings.Count, aBottomCount, aBottomR);
		if (aBottomCount < 4) and (aStrings.Count >= 4) then
			aR := aTopR
		else
			aR := aBottomR;

		Top := aR.Top;
		Left := aR.Left;
		Width := aR.Right - aR.Left;
		Height := aR.Bottom - aR.Top + 2;

		Show;
		try
			ModalResult := 0;
			while ModalResult = 0 do
				Application.ProcessMessages;
			Result := ModalResult = mrOk;
			if Result and (ListBox.ItemIndex >= 0) then
				anIndex := ListBox.ItemIndex;
		finally
			Free;
		end;
	end;
end;

end.
