[Lazarus] Scroll Wheel
Howard Page-Clark
hdpc at talktalk.net
Fri Apr 11 21:21:59 CEST 2014
On 11/04/2014 19:33, Timothy Groves wrote:
> No; I am unsure as to how to do that. Would I need to create a
> descendant class, or does Lazarus support overriding without doing so?
The following should give you an idea how to develop the hint Mattias gave:
===code===
unit testIntWheelEdit;
{$mode objfpc}{$H+}
interface
uses
SysUtils, Forms, StdCtrls, LMessages, Spin, Classes;
type
{ TIntWheelEdit }
TIntWheelEdit=class(TCustomEdit)
private
function GetAsInteger: integer;
protected
procedure WMMouseWheel(var Message: TLMMouseEvent); message
LM_MOUSEWHEEL;
procedure KeyPress(var Key: char); override;
public
property AsInteger: integer read GetAsInteger;
end;
{ TForm1 }
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
private
intEdit: TIntWheelEdit;
spinEdit: TSpinEdit;
procedure IntEditChange(Sender: TObject);
end;
var
Form1: TForm1;
implementation
{$R *.lfm}
{ TForm1 }
procedure TForm1.FormCreate(Sender: TObject);
begin
intEdit:=TIntWheelEdit.Create(Self);
intEdit.Left:=10;
intEdit.Top:=10;
intEdit.OnChange:=@IntEditChange;
intEdit.TabOrder:=0;
intEdit.Parent:=Self;
spinEdit:=TSpinEdit.Create(Self);
spinEdit.Top:=10;
spinEdit.Left:=100;
spinEdit.MinValue:=-1000;
spinEdit.MaxValue:=1000;
spinEdit.ReadOnly:=True;
spinEdit.Parent:=Self;
end;
procedure TForm1.IntEditChange(Sender: TObject);
begin
if Sender is TIntWheelEdit then
spinEdit.Value:=TIntWheelEdit(Sender).AsInteger;
end;
{ TIntWheelEdit }
function TIntWheelEdit.GetAsInteger: integer;
begin
Result:=StrToIntDef(Text, 0);
end;
procedure TIntWheelEdit.WMMouseWheel(var Message: TLMMouseEvent);
var
i: integer;
begin
i:=StrToIntDef(Text, 0);
if Message.WheelDelta >=0 then
Inc(i)
else Dec(i);
Text:=IntToStr(i);
Message.Result:=1;
end;
procedure TIntWheelEdit.KeyPress(var Key: char);
begin
case Length(Text)=0 of
False: if Key in [#8,'0'..'9'] then
inherited KeyPress(Key)
else Key:=#0;
True: if Key in [#8,'-','0'..'9'] then
inherited KeyPress(Key)
else Key := #0;
end;
end;
end.
===code end===
More information about the Lazarus
mailing list