Después de unas cuantas horas buenas os pongo el código de dos componentes que se usaran en el módulo que estamos, son iguales, uno para integer y otro para double, son Spinedit para tablas
Código Delphi
[-]
unit NewDBSpinEdit;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Buttons, DBneweditjl , mask, DbTables, DB, DBCtrls;
type
TNewDBSpinEdit = class(TDBNewEditJL)
private
FButtonUp : TBitBtn;
FButtonDown : TBitBtn;
FWidthButton : Integer;
FCaptionUp : String;
FCaptionDown : String;
FProportional : Boolean;
FMinValue : LongInt;
FMaxValue : LongInt;
FIncrement : LongInt;
FEditorEnabled: Boolean;
FFontButtons : TFont;
procedure SetGlyph(const Value: TBitmap);
function GetGlyph:TBitmap;
procedure SetGlyphDown(const Value: TBitmap);
function GetGlyphDown:TBitmap;
procedure autofit;
procedure TextChanged(sender: TObject);
procedure setCaptionUp(const Value:String);
procedure setCaptionDown(const Value:String);
procedure setWidthButton(const Value:Integer);
procedure setProportional(const Value:Boolean);
function GetValue: LongInt;
procedure SetValue (NewValue: LongInt);
function CheckValue (NewValue: LongInt): LongInt;
procedure CMEnter(var Message: TCMGotFocus); message CM_ENTER;
procedure CMExit(var Message: TCMExit); message CM_EXIT;
procedure WMPaste(var Message: TWMPaste); message WM_PASTE;
procedure WMCut(var Message: TWMCut); message WM_CUT;
protected
procedure WMSize(var Message: TWMSize); message WM_SIZE;
procedure CreateWnd;override;
function GetOnButtonUpClick: TNotifyEvent;
function GetOnButtonDownClick: TNotifyEvent;
procedure SetOnButtonUpClick(Value: TNotifyEvent);
procedure SetOnButtonDownClick(Value: TNotifyEvent);
procedure KeyPress(var Key: Char); override;
function IsValidChar(Key: Char): Boolean; virtual;
procedure UpClick (Sender: TObject); virtual;
procedure DownClick (Sender: TObject); virtual;
procedure KeyDown(var Key: Word; Shift: TShiftState); override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property OnButtonUpClick: TNotifyEvent read GetOnButtonUpClick write SetOnButtonUpClick;
property OnButtonDownClick: TNotifyEvent read GetOnButtonDownClick write SetOnButtonDownClick;
property GlyphUP :TBitmap read GetGlyph write SetGlyph;
property GlyphDown :TBitmap read GetGlyphDown write SetGlyphDown;
property CaptionUp :String read FCaptionUp write SetCaptionUp;
property CaptionDown :String read FCaptionDown write SetCaptionDown;
property WidthButton :Integer read FWidthButton write SetWidthButton default 15;
property Proportional :Boolean read FProportional write SetProportional default True;
property MaxValue :LongInt read FMaxValue write FMaxValue;
property MinValue :LongInt read FMinValue write FMinValue;
property Value :LongInt read GetValue write SetValue;
property Increment :LongInt read FIncrement write FIncrement default 1;
property FontButtons :TFont read FFontButtons write FFontButtons;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Data Controls', [TNewDBSpinEdit]);
end;
procedure TNewDBSpinEdit.WMCut(var Message: TWMCut);
begin
if not FEditorEnabled or ReadOnly then Exit;
inherited;
end;
procedure TNewDBSpinEdit.WMPaste(var Message: TWMPaste);
begin
if not FEditorEnabled or ReadOnly then Exit;
inherited;
end;
procedure TNewDBSpinEdit.WMSize(var Message: TWMSize);
begin
inherited;
autofit;
end;
function TNewDBSpinEdit.CheckValue(NewValue: Integer): LongInt;
begin
Result := NewValue;
if (FMaxValue <> FMinValue) then
begin
if NewValue < FMinValue then Result := FMinValue
else if NewValue > FMaxValue then Result := FMaxValue;
end;
end;
procedure TNewDBSpinEdit.CMEnter(var Message: TCMGotFocus);
begin
if AutoSelect and not (csLButtonDown in ControlState) then
SelectAll;
inherited;
end;
procedure TNewDBSpinEdit.CMExit(var Message: TCMExit);
begin
inherited;
if CheckValue (Value) <> Value then
SetValue (Value);
end;
constructor TNewDBSpinEdit.Create(AOwner: TComponent);
begin
inherited;
width :=121;
height :=24;
FCaptionDown :='q';
FCaptionUp :='p';
FWidthButton :=15;
FontButtons :=TFont.Create;
with FFontButtons do
begin
Name :='wingdings 3';
Size :=7;
end;
FButtonUP :=TBitbtn.Create (self);
with FButtonUP do
begin
width :=FWidthButton;
height :=15;
Font :=FFontButtons;
top :=1;
parent :=Self;
Caption :=FCaptionUp;
OnClick :=UpClick;
end;
FButtonDown :=TBitbtn.Create (self);
with FButtonDown do
begin
width :=FWidthButton;
height :=15;
Font :=FFontButtons;
top :=1;
parent :=Self;
Caption :=FCaptionDown;
OnClick :=DownClick;
end;
FProportional :=True;
ControlStyle := ControlStyle - [csSetCaption];
FIncrement := 1;
Text :='0';
end;
destructor TNewDBSpinEdit.Destroy;
begin
FButtonUP.Free;
FbuttonDown.Free;
inherited Destroy;
end;
procedure TNewDBSpinEdit.DownClick(Sender: TObject);
begin
if ReadOnly then MessageBeep(0) else Value := Value - FIncrement;
EditCanModify;
end;
procedure TNewDBSpinEdit.setCaptionDown(const Value: String);
begin
if FCaptionDown<>value then FCaptionDown:=Value;
FButtonDown.Caption:=FCaptionDown;
end;
procedure TNewDBSpinEdit.setCaptionUp(const Value: String);
begin
if FCaptionUp<>value then FCaptionUp:=Value;
FButtonUp.Caption:=FCaptionUp;
end;
procedure TNewDBSpinEdit.setProportional(const Value: Boolean);
begin
if FProportional<>value then FProportional:=Value;
end;
procedure TNewDBSpinEdit.SetValue(NewValue: Integer);
begin
Text := IntToStr (CheckValue (NewValue));
EditText := Text;
end;
procedure TNewDBSpinEdit.setWidthButton(const Value: Integer);
begin
if FWidthButton<>value then FWidthButton:=Value;
autofit;
end;
function TNewDBSpinEdit.GetOnButtonDownClick: TNotifyEvent;
begin
Result := FButtonDown.OnClick;
end;
function TNewDBSpinEdit.GetOnButtonUpClick: TNotifyEvent;
begin
Result := FButtonUP.OnClick;
end;
function TNewDBSpinEdit.GetValue: LongInt;
begin
try
Result := StrToInt (Text);
except
Result := FMinValue;
end;
end;
function TNewDBSpinEdit.IsValidChar(Key: Char): Boolean;
begin
Result := (Key in ['+', '-', '0'..'9']) or ((Key < #32) and (Key <> Chr(VK_RETURN)));
if not FEditorEnabled and Result and ((Key >= #32) or (Key = Char(VK_BACK)) or (Key = Char(VK_DELETE))) then Result := False;
end;
procedure TNewDBSpinEdit.KeyDown(var Key: Word; Shift: TShiftState);
begin
if Key = VK_UP then UpClick (Self) else if Key = VK_DOWN then DownClick (Self);
inherited KeyDown(Key, Shift);
end;
procedure TNewDBSpinEdit.KeyPress(var Key: Char);
begin
if not IsValidChar(Key) then
begin
Key := #0;
MessageBeep(0)
end;
if Key <> #0 then inherited KeyPress(Key);
end;
procedure TNewDBSpinEdit.SetOnButtonDownClick(Value: TNotifyEvent);
begin
FButtonDown.onClick := Value;
end;
procedure TNewDBSpinEdit.SetOnButtonUpClick(Value: TNotifyEvent);
begin
FButtonUP.onClick := Value;
end;
procedure TNewDBSpinEdit.SetGlyph(const Value: TBitmap);
begin
FButtonUp.Glyph.assign(Value);
end;
procedure TNewDBSpinEdit.SetGlyphDown(const Value: TBitmap);
begin
FButtonDown.Glyph.assign(Value);
end;
function TNewDBSpinEdit.GetGlyph: TBitmap;
begin
result:=FButtonUp.Glyph;
end;
function TNewDBSpinEdit.GetGlyphDown: TBitmap;
begin
result:=FButtonDown.Glyph;
end;
procedure TNewDBSpinEdit.CreateWnd;
begin
inherited;
autofit;
end;
procedure TNewDBSpinEdit.autofit;
begin
FbuttonUP.top:=1;
FbuttonUP.Height :=height-6;
FButtonUp.Font:=FFontButtons;
if FProportional then FButtonUp.Width:=FbuttonUP.Height
else FButtonUp.Width:=FWidthButton;
FbuttonUP.Left := Width-FButtonUP.width-5;
FbuttonDown.top:=1;
FButtonDown.Font:=FFontButtons;
FbuttonDown.Height :=height-6;
if FProportional then FButtonDown.Width:=FButtonDown.Height
else FButtonDown.Width:=FWidthButton;
FbuttonDown.Left := 1;
Self.Perform(EM_SETMARGINS,EC_LEFTMARGIN,(FButtonDown.Width+4));
Self.Perform(EM_SETMARGINS,EC_RIGHTMARGIN,(FButtonUP.Width+4)*$10000);
Self.Repaint;
end;
procedure TNewDBSpinEdit.TextChanged(sender: TObject);
begin
Autofit;
end;
procedure TNewDBSpinEdit.UpClick(Sender: TObject);
begin
if ReadOnly then MessageBeep(0) else
Value := Value + FIncrement;
EditCanModify;
end;
end.
El otro
Código Delphi
[-]
unit NewDBSpinEditDouble;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Buttons, DBneweditjl , mask, DbTables, DB, DBCtrls;
type
TNewDBSpinEditDouble = class(TDBNewEditJL)
private
FButtonUp : TBitBtn;
FButtonDown : TBitBtn;
FWidthButton : Integer;
FCaptionUp : String;
FCaptionDown : String;
FProportional : Boolean;
FMinValue : Double;
FMaxValue : Double;
FIncrement : Double;
FEditorEnabled: Boolean;
FFontButtons : TFont;
FDecimals : Integer;
procedure SetGlyph(const Value: TBitmap);
function GetGlyph:TBitmap;
procedure SetGlyphDown(const Value: TBitmap);
function GetGlyphDown:TBitmap;
procedure autofit;
procedure TextChanged(sender: TObject);
procedure setCaptionUp(const Value:String);
procedure setCaptionDown(const Value:String);
procedure setWidthButton(const Value:Integer);
procedure setProportional(const Value:Boolean);
function GetValue: Double;
procedure SetValue (NewValue: Double);
function CheckValue (NewValue: Double): Double;
procedure CMEnter(var Message: TCMGotFocus); message CM_ENTER;
procedure CMExit(var Message: TCMExit); message CM_EXIT;
procedure WMPaste(var Message: TWMPaste); message WM_PASTE;
procedure WMCut(var Message: TWMCut); message WM_CUT;
procedure setDecimals(const Value:Integer);
protected
procedure WMSize(var Message: TWMSize); message WM_SIZE;
procedure CreateWnd;override;
function GetOnButtonUpClick: TNotifyEvent;
function GetOnButtonDownClick: TNotifyEvent;
procedure SetOnButtonUpClick(Value: TNotifyEvent);
procedure SetOnButtonDownClick(Value: TNotifyEvent);
procedure KeyPress(var Key: Char); override;
function IsValidChar(Key: Char): Boolean; virtual;
procedure UpClick (Sender: TObject); virtual;
procedure DownClick (Sender: TObject); virtual;
procedure KeyDown(var Key: Word; Shift: TShiftState); override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property OnButtonUpClick: TNotifyEvent read GetOnButtonUpClick write SetOnButtonUpClick;
property OnButtonDownClick: TNotifyEvent read GetOnButtonDownClick write SetOnButtonDownClick;
property GlyphUP :TBitmap read GetGlyph write SetGlyph;
property GlyphDown :TBitmap read GetGlyphDown write SetGlyphDown;
property CaptionUp :String read FCaptionUp write SetCaptionUp;
property CaptionDown :String read FCaptionDown write SetCaptionDown;
property WidthButton :Integer read FWidthButton write SetWidthButton default 15;
property Proportional :Boolean read FProportional write SetProportional default True;
property MaxValue ouble read FMaxValue write FMaxValue;
property MinValue ouble read FMinValue write FMinValue;
property Value ouble read GetValue write SetValue;
property Increment ouble read FIncrement write FIncrement;
property FontButtons :TFont read FFontButtons write FFontButtons;
property Decimals :Integer read FDecimals write SetDecimals;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Data Controls', [TNewDBSpinEditDouble]);
end;
procedure TNewDBSpinEditDouble.WMCut(var Message: TWMCut);
begin
if not FEditorEnabled or ReadOnly then Exit;
inherited;
end;
procedure TNewDBSpinEditDouble.WMPaste(var Message: TWMPaste);
begin
if not FEditorEnabled or ReadOnly then Exit;
inherited;
end;
procedure TNewDBSpinEditDouble.WMSize(var Message: TWMSize);
begin
inherited;
autofit;
end;
function TNewDBSpinEditDouble.CheckValue(NewValue: Double): Double;
begin
Result := NewValue;
if (FMaxValue <> FMinValue) then
begin
if NewValue < FMinValue then Result := FMinValue
else if NewValue > FMaxValue then Result := FMaxValue;
end;
end;
procedure TNewDBSpinEditDouble.CMEnter(var Message: TCMGotFocus);
begin
if AutoSelect and not (csLButtonDown in ControlState) then
SelectAll;
inherited;
end;
procedure TNewDBSpinEditDouble.CMExit(var Message: TCMExit);
begin
inherited;
if CheckValue (Value) <> Value then
SetValue (Value);
end;
constructor TNewDBSpinEditDouble.Create(AOwner: TComponent);
begin
inherited;
width :=121;
height :=24;
FCaptionDown :='q';
FCaptionUp :='p';
FWidthButton :=15;
FontButtons :=TFont.Create;
with FFontButtons do
begin
Name :='wingdings 3';
Size :=7;
end;
FButtonUP :=TBitbtn.Create (self);
with FButtonUP do
begin
width :=FWidthButton;
height :=15;
Font :=FFontButtons;
top :=1;
parent :=Self;
Caption :=FCaptionUp;
OnClick :=UpClick;
end;
FButtonDown :=TBitbtn.Create (self);
with FButtonDown do
begin
width :=FWidthButton;
height :=15;
Font :=FFontButtons;
top :=1;
parent :=Self;
Caption :=FCaptionDown;
OnClick :=DownClick;
end;
FProportional :=True;
ControlStyle := ControlStyle - [csSetCaption];
FIncrement := 0.01;
Text :='0,00';
FDecimals :=2;
end;
destructor TNewDBSpinEditDouble.Destroy;
begin
FButtonUP.Free;
FbuttonDown.Free;
FFontButtons.Free;
inherited Destroy;
end;
procedure TNewDBSpinEditDouble.DownClick(Sender: TObject);
begin if ReadOnly then MessageBeep(0)
else
Value := Value - FIncrement;
EditCanModify;
end;
procedure TNewDBSpinEditDouble.setCaptionDown(const Value: String);
begin
if FCaptionDown<>value then FCaptionDown:=Value;
FButtonDown.Caption:=FCaptionDown;
end;
procedure TNewDBSpinEditDouble.setCaptionUp(const Value: String);
begin
if FCaptionUp<>value then FCaptionUp:=Value;
FButtonUp.Caption:=FCaptionUp;
end;
procedure TNewDBSpinEditDouble.setDecimals(const Value: Integer);
begin
if (value>4) or (Value<0) then
begin
MessageBeep(1000);
ShowMessage('Los valores de este apartado estan entre 0 y 4 decimales');
end else if FDecimals<>value then FDecimals:=Value;
end;
procedure TNewDBSpinEditDouble.setProportional(const Value: Boolean);
begin
if FProportional<>value then FProportional:=Value;
end;
procedure TNewDBSpinEditDouble.SetValue(NewValue: Double);
begin
Text := FloatToStr (CheckValue (NewValue));
EditText := Text;
case FDecimals of
0:Self.Text:=FormatFloat('#0',Self.Value);
1:Self.Text:=FormatFloat('#0.0',Self.Value);
2:Self.Text:=FormatFloat('#0.#0',Self.Value);
3:Self.Text:=FormatFloat('#0.##0',Self.Value);
4:Self.Text:=FormatFloat('#0.###0',Self.Value);
end;
end;
procedure TNewDBSpinEditDouble.setWidthButton(const Value: Integer);
begin
if FWidthButton<>value then FWidthButton:=Value;
autofit;
end;
function TNewDBSpinEditDouble.GetOnButtonDownClick: TNotifyEvent;
begin
Result := FButtonDown.OnClick;
end;
function TNewDBSpinEditDouble.GetOnButtonUpClick: TNotifyEvent;
begin
Result := FButtonUP.OnClick;
end;
function TNewDBSpinEditDouble.GetValue: Double;
begin
try
Result := StrToFloat (Text);
except
Result := FMinValue;
end;
end;
function TNewDBSpinEditDouble.IsValidChar(Key: Char): Boolean;
begin
Result := (Key in [DecimalSeparator, '+', '-', '0'..'9']) or ((Key < #32) and (Key <> Chr(VK_RETURN)));
if not FEditorEnabled and Result and ((Key >= #32) or (Key = Char(VK_BACK)) or (Key = Char(VK_DELETE))) then Result := False;
end;
procedure TNewDBSpinEditDouble.KeyDown(var Key: Word; Shift: TShiftState);
begin
if Key = VK_UP then UpClick (Self) else if Key = VK_DOWN then DownClick (Self);
inherited KeyDown(Key, Shift);
end;
procedure TNewDBSpinEditDouble.KeyPress(var Key: Char);
begin
if not IsValidChar(Key) then
begin
Key := #0;
MessageBeep(0)
end;
if Key <> #0 then inherited KeyPress(Key);
end;
procedure TNewDBSpinEditDouble.SetOnButtonDownClick(Value: TNotifyEvent);
begin
FButtonDown.onClick := Value;
end;
procedure TNewDBSpinEditDouble.SetOnButtonUpClick(Value: TNotifyEvent);
begin
FButtonUP.onClick := Value;
end;
procedure TNewDBSpinEditDouble.SetGlyph(const Value: TBitmap);
begin
FButtonUp.Glyph.assign(Value);
end;
procedure TNewDBSpinEditDouble.SetGlyphDown(const Value: TBitmap);
begin
FButtonDown.Glyph.assign(Value);
end;
function TNewDBSpinEditDouble.GetGlyph: TBitmap;
begin
result:=FButtonUp.Glyph;
end;
function TNewDBSpinEditDouble.GetGlyphDown: TBitmap;
begin
result:=FButtonDown.Glyph;
end;
procedure TNewDBSpinEditDouble.CreateWnd;
begin
inherited;
autofit;
end;
procedure TNewDBSpinEditDouble.autofit;
begin
FbuttonUP.top:=1;
FbuttonUP.Height :=height-6;
FButtonUp.Font:=FFontButtons;
if FProportional then FButtonUp.Width:=FbuttonUP.Height
else FButtonUp.Width:=FWidthButton;
FbuttonUP.Left := Width-FButtonUP.width-5;
FbuttonDown.top:=1;
FButtonDown.Font:=FFontButtons;
FbuttonDown.Height :=height-6;
if FProportional then FButtonDown.Width:=FButtonDown.Height
else FButtonDown.Width:=FWidthButton;
FbuttonDown.Left := 1;
case FDecimals of
0:Self.Text:=FormatFloat('#0',Self.Value);
1:Self.Text:=FormatFloat('#0.0',Self.Value);
2:Self.Text:=FormatFloat('#0.#0',Self.Value);
3:Self.Text:=FormatFloat('#0.##0',Self.Value);
4:Self.Text:=FormatFloat('#0.###0',Self.Value);
end;
Self.Perform(EM_SETMARGINS,EC_LEFTMARGIN,(FButtonDown.Width+4));
Self.Perform(EM_SETMARGINS,EC_RIGHTMARGIN,(FButtonUP.Width+4)*$10000);
Self.Repaint;
end;
procedure TNewDBSpinEditDouble.TextChanged(sender: TObject);
begin
Autofit;
end;
procedure TNewDBSpinEditDouble.UpClick(Sender: TObject);
begin
if ReadOnly then MessageBeep(0) else
Value := Value + FIncrement;
EditCanModify;
end;
end.
Espero os sean de utilidad.