I am trying to develop a new TEdit-Component.
TDBFilterEdit = class(TEdit)
The component is meant to Filter an associated DataSet based on the string that is entered in its Edit-Field.
this is what my component looks like:
type
TDBFilterEdit = class(TEdit)
private
{ Private-Deklarationen }
fFilter:String;
fDataSource:TDataSource;
fDataSet:TDataSet;
fText:string;
protected
{ Protected-Deklarationen }
procedure SetFilter(value:String);
procedure SetDS(value:TDataSource);
procedure FilterRecords(DataSet:TDataSet; var Accept:Boolean);
procedure Change(Sender:TObject);
procedure SetText(value:String);
public
{ Public-Deklarationen }
constructor Create(AOwner:TComponent);
published
{ Published-Deklarationen }
property Text:String read fText write SetText;
property Filter:String read fFilter write SetFilter;
property DataSource:TDataSource read fDataSource write SetDS;
end;
Now, I am pretty Novice when it comes to component-development. My first Idea was to Override the OnFilterRecord-method of the Dataset as soon as the DataSource gets assigned to my component and trigger it whenever the text of my Edit-component changes.
procedure TDBFilterEdit.SetDS(value:TDataSource);
var
myaccept:Boolean;
begin
fDataSource:=value;
fDataSet:=fDataSource.DataSet;
if fDataSet=nil then Exit;
fDataSet.OnFilterRecord:=FilterRecords;
if Filter<>'' then fDataSet.OnFilterRecord(fDataSet,myaccept);
end;
My Problem is, I don't know how to make the component aware that its Text-property got updated. I tried overriding the OnChange-Method with following code
procedure TDBFilterEdit.Change(Sender:TObject);
begin
Filter:=Text;
inherited Change();
end;
however, to no avail so far.
My Problem is, I don't know how to make the component aware that its Text-property got updated.
The Text property is inherited from TControl. When the property value changes, TControl issues a CM_TEXTCHANGED notification message to itself. Descendant classes can handle that message by either:
using a message handler:
type
TDBFilterEdit = class(TEdit)
...
procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
...
published
...
// DO NOT redeclare the Text property here!
// It is already published by TEdit...
end;
procedure TDBFilterEdit.CMTextChanged(var Message: TMessage);
begin
inherited;
// use new Text value as needed...
Filter := Text;
end;
overriding the virtual WndProc() method.
type
TDBFilterEdit = class(TEdit)
...
protected
...
procedure WndProc(var Message: TMessage); override;
...
end;
procedure TDBFilterEdit.WndProc(var Message: TMessage);
begin
inherited;
if Message.Msg = CM_TEXTCHANGED then
begin
// use new Text value as needed...
Filter := Text;
end;
end;
As for the rest of your component, it should look more like this:
type
TDBFilterEdit = class(TEdit)
private
{ Private-Deklarationen }
fDataSource: TDataSource;
fDataSet: TDataSet;
fFilter: String;
procedure FilterRecords(DataSet: TDataSet; var Accept: Boolean);
procedure SetDataSource(Value: TDataSource);
procedure SetDataSet(Value: TDataSet);
procedure SetFilter(const Value: String);
procedure StateChanged(Sender: TObject);
procedure UpdateDataSetFilter;
protected
{ Protected-Deklarationen }
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
procedure WndProc(var Message: TMessage); override;
public
{ Public-Deklarationen }
destructor Destroy; override;
published
{ Published-Deklarationen }
property DataSource: TDataSource read fDataSource write SetDataSource;
property Filter: String read fFilter write SetFilter;
end;
...
destructor TDBFilterEdit.Destroy;
begin
SetDataSource(nil);
inherited;
end;
procedure TDBFilterEdit.FilterRecords(DataSet: TDataSet; var Accept: Boolean);
begin
// ...
end;
procedure TDBFilterEdit.Notification(AComponent: TComponent; Operation: TOperation);
begin
inherited Notification(AComponent, Operation);
if Operation = opRemove then
begin
if AComponent = fDataSource then
begin
SetDataSet(nil);
fDataSource := nil;
end
else if AComponent = fDataSet then
begin
fDataSet := nil;
end;
end;
end;
procedure TDBFilterEdit.SetFilter(const Value: String);
begin
if fFilter <> Value then
begin
fFilter := Value;
UpdateDataSetFilter;
end;
end;
procedure TDBFilterEdit.SetDataSource(Value: TDataSource);
begin
if fDataSource <> Value then
begin
SetDataSet(nil);
if fDataSource <> nil then
begin
fDataSource.RemoveFreeNotification(Self);
fDataSource.OnStateChange := nil;
end;
fDataSource := Value;
if fDataSource <> nil then
begin
fDataSource.FreeNotification(Self);
fDataSource.OnStateChange := StateChanged;
SetDataSet(fDataSource.DataSet);
end;
end;
end;
procedure TDBFilterEdit.SetDataSet(Value: TDataSet);
begin
if fDataSet <> Value then
begin
if fDataSet <> nil then
begin
fDataSet.RemoveFreeNotification(Self);
fDataSet.OnFilterRecord := nil;
end;
fDataSet := Value;
if fDataSet <> nil then
begin
fDataSet.FreeNotification(Self);
fDataSet.OnFilterRecord := FilterRecords;
UpdateDataSetFilter;
end;
end;
end;
procedure TDBFilterEdit.StateChanged(Sender: TObject);
begin
if fDataSource.DataSet <> fDataSet then
SetDataSet(fDataSource.DataSet);
end;
procedure TDBFilterEdit.UpdateDataSetFilter;
begin
if fDataSet <> nil then
begin
fDataSet.Filter := fFilter;
fDataSet.Filtered := fFilter <> '';
end;
end;
procedure TDBFilterEdit.WndProc(var Message: TMessage);
begin
inherited;
if Message.Msg = CM_TEXTCHANGED then
Filter := Text;
end;
UPDATE: sorry, my bad. The CM_TEXTCHANGED message is only sent when the Text property is updated programmably in code. To detect when the user changed the text, you need to handle the Win32 EN_CHANGE notification instead:
using a message handler:
type
TDBFilterEdit = class(TEdit)
...
procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
procedure CNCommand(var Message: TWMCommand); message CN_COMMAND;
...
published
...
// DO NOT redeclare the Text property here!
// It is already published by TEdit...
end;
procedure TDBFilterEdit.CMTextChanged(var Message: TMessage);
begin
inherited;
// use new Text value as needed...
Filter := Text;
end;
procedure TDBFilterEdit.CNCommand(var Message: TWMCommand);
begin
inherited;
if Message.NotifyCode = EN_CHANGE then
begin
// use new Text value as needed...
Filter := Text;
end;
end;
overriding the virtual WndProc() method.
type
TDBFilterEdit = class(TEdit)
...
protected
...
procedure WndProc(var Message: TMessage); override;
...
end;
procedure TDBFilterEdit.WndProc(var Message: TMessage);
begin
inherited;
case Message.Msg of
CM_TEXTCHANGED: begin
// use new Text value as needed...
Filter := Text;
end;
CN_COMMAND: begin
if TWMCommand(Message).NotifyCode = EN_CHANGE then
begin
// use new Text value as needed...
Filter := Text;
end;
end;
end;
end;
In fact, TCustomEdit already handles EN_CHANGE for you, and will call its virtual Change() method (to fire its OnChange event), which you can override:
type
TDBFilterEdit = class(TEdit)
...
protected
...
procedure Change; override;
...
end;
procedure TDBFilterEdit.Change;
begin
inherited;
// use new Text value as needed...
Filter := Text;
end;
Related
I am creating a set of properties in a collection item. Each item has a different set of properties according to its type:
type
TMyProps = class(TPersistent)
private
Fcommom: boolean;
procedure Setcommom(const Value: boolean);
published
property commom: boolean read Fcommom write Setcommom;
end;
TMyPropsClass = class of TMyProps;
TFieldPropsFloat = class(TMyProps)
private
FDecimalplaces: integer;
procedure SetDecimalplaces(const Value: integer);
published
property Decimalplaces: integer read FDecimalplaces write SetDecimalplaces;
end;
TFieldPropsStr = class(TMyProps)
private
FLength: integer;
procedure SetLength(const Value: integer);
published
property Length: integer read FLength write SetLength;
end;
TMyCollection = class(TOwnedCollection)
end;
TMyItem = class(TCollectionItem)
private
FMyPropsClass: TMyPropsClass;
FMyProps: TMyProps;
procedure ReadMyProps(Reader: TReader);
procedure WriteMyProps(Writer: TWriter);
procedure RecreateMyProps;
procedure SetMyProps(const Value: TMyProps);
procedure SetMyPropsClass(const Value: TMyPropsClass);
protected
procedure DefineProperties(Filer: TFiler); override;
public
procedure AfterConstruction; override;
published
property MyPropsClass: TMyPropsClass read FMyPropsClass write SetMyPropsClass;
property MyProps: TMyProps read FMyProps write SetMyProps stored false;
end;
in 'TMyItem' an error occurs while loading properties written to '.dfm' file because 'MyProps' has not yet been built with 'MyPropsClass' properties that have not yet been loaded from '.dfm'
How to solve it? Is this the best approach?
Edit: Also, I'm trying to follow the tip Remy Lebeau gave me(comments bellow), but, I can't write in every item on the list.
///...
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Samples', [TMyComponent]);
end;
procedure TMyItem.AfterConstruction;
begin
inherited;
FMyPropsClass := TFieldPropsStr;
RecreateMyProps;
end;
procedure TMyItem.DefineProperties(Filer: TFiler);
begin
inherited DefineProperties(Filer);
Filer.DefineProperty('MyProps', ReadMyProps, WriteMyProps, True);
end;
type
TReaderAccess = class(TReader);
TWriterAccess = class(TWriter);
procedure TMyItem.ReadMyProps(Reader: TReader);
begin
MyProps := TMyPropsClass(FindClass(Reader.ReadString)).Create;
Reader.CheckValue(vaCollection);
Reader.ReadListBegin;
while not Reader.EndOfList do
TReaderAccess(Reader).ReadProperty(MyProps);
Reader.ReadListEnd;
Reader.ReadListEnd;
end;
procedure TMyItem.RecreateMyProps;
begin
if FMyProps <> nil then
FMyProps.Free;
FMyProps := FMyPropsClass.Create;
end;
procedure TMyItem.SetMyProps(const Value: TMyProps);
begin
FMyProps := Value;
end;
procedure TMyItem.SetMyPropsClass(const Value: TMyPropsClass);
begin
if FMyPropsClass <> Value then
begin
FMyPropsClass := Value;
RecreateMyProps;
end;
end;
procedure TMyItem.WriteMyProps(Writer: TWriter);
begin
Writer.WriteString(MyProps.ClassName); //if comments this line, write fine
TWriterAccess(Writer).WriteValue(vaCollection);
Writer.WriteListBegin;
Writer.WriteProperties(MyProps);
Writer.WriteListEnd;
Writer.WriteListEnd;
end;
{ TMyProps }
procedure TMyProps.Setcommom(const Value: boolean);
begin
Fcommom := Value;
end;
{ TFieldPropsFloat }
procedure TFieldPropsFloat.SetDecimalplaces(const Value: integer);
begin
FDecimalplaces := Value;
end;
{ TFieldPropsStr }
procedure TFieldPropsStr.SetLength(const Value: integer);
begin
FLength := Value;
end;
{ TButton1 }
procedure TMyComponent.AfterConstruction;
begin
inherited;
FMyCollection := TMyCollection.Create(Self, TMyItem);
end;
procedure TMyComponent.SetMyCollection(const Value: TMyCollection);
begin
FMyCollection := Value;
end;
How correctly implements ReadMyProps and WriteMyProps procedures for each item of collection?
Mark the MyProps property as stored=false (or don't make it published at all) and then override the virtual DefineProperties() method to stream the MyProps data manually. See Storing and Loading Unpublished Properties: Overriding the DefineProperties Method in Embarcadero's DocWiki, and Streaming non-published TPersistent Properties – A Better Way on the Delphi Codesmith blog.
For example:
type
TMyItem = class(TCollectionItem)
private
procedure ReadMyProps(Reader: TReader);
procedure WriteMyProps(Writer: TWriter);
protected
procedure DefineProperties(Filer: TFiler); override;
published
MyPropsClass: TMyPropsClass;
MyProps: TMyProps stored false;
end;
procedure TMyItem.DefineProperties(Filer: TFiler);
begin
inherited DefineProperties(Filer);
Filer.DefineProperty('MyProps', ReadMyProps, WriteMyProps, True);
end;
type
TReaderAccess = class(TReader);
TWriterAccess = class(TWriter);
procedure TMyItem.ReadMyProps(Reader: TReader);
begin
MyProps := TMyPropsClass(FindClass(Reader.ReadString)).Create;
Reader.CheckValue(vaCollection);
Reader.ReadListBegin;
while not Reader.EndOfList do
TReaderAccess(Reader).ReadProperty(MyProps);
Reader.ReadListEnd;
Reader.ReadListEnd;
end;
procedure TMyItem.WriteMyProps(Writer: TWriter);
begin
Writer.WriteString(MyProps.ClassName);
TWriterAccess(Writer).WriteValue(vaCollection);
Writer.WriteListBegin;
Writer.WriteProperties(MyProps);
Writer.WriteListEnd;
Writer.WriteListEnd;
end;
Basically I have this problem: CapsLock password message in TEdit visually fails with VCL Styles.
What I want to do is not to solve the problem as shown in the answer or the comments.
I want to disable that ugly hint window entirely. and instead show an image letting the user know that the caps are locked.
like this
I found the solution to my problem, It involves a hack that I would rather not use.
It goes like this.
Override WndProc.
code
type
TEdit = class (Vcl.StdCtrls.TEdit)
protected
procedure WndProc(var Message: TMessage); override;
end;
Intercept the EM_SHOWBALLOONTIPmessage and you are done
code
procedure TEdit.WndProc(var Message: TMessage);
begin
if Message.Msg = EM_SHOWBALLOONTIP then
showmessage('Do your thing.')
else
inherited;
end;
For more information check the MSDN documentation:
How do I suppress the CapsLock warning on password edit controls?
This is a descendant of TEdit that would allow to suppress the CapsLock warning on password edit controls, if a certain FOnPasswordCaps events are assigned with PasswordChar <> #0
unit NCREditUnit;
interface
uses
Vcl.StdCtrls,
vcl.Controls,
Winapi.Messages,
System.Classes;
type
TNCREdit = class(TEdit)
private
FOnPasswordCapsLocked: TNotifyEvent;
FIsCapsLocked: boolean;
FOnPasswordCapsFreed: TNotifyEvent;
FBlockCapsBalloonTip: boolean;
FValuePasswordChrOnCaps: boolean;
procedure SetOnPasswordCapsEvents;
procedure SetOnPasswordCapsFreed(const aValue: TNotifyEvent);
procedure SetOnPasswordCapsLocked(const aValue: TNotifyEvent);
protected
procedure WndProc(var Message: TMessage); override;
procedure KeyUp(var Key: Word; Shift: TShiftState); override;
procedure DoEnter; override;
procedure DoExit; override;
published
property BlockCapsBalloonTip: boolean read FBlockCapsBalloonTip write FBlockCapsBalloonTip default False;
property ValuePasswordChrOnCaps: boolean read FValuePasswordChrOnCaps write FValuePasswordChrOnCaps default True;
//... The usual property declaration of TEdit
property OnPasswordCapsLocked: TNotifyEvent read FOnPasswordCapsLocked write SetOnPasswordCapsLocked;
property OnPasswordCapsFreed: TNotifyEvent read FOnPasswordCapsFreed write SetOnPasswordCapsFreed;
end;
implementation
uses
Winapi.CommCtrl,
Winapi.Windows;
{ TNCREdit }
procedure TNCREdit.DoEnter;
begin
inherited;
if FBlockCapsBalloonTip then
begin
FIsCapsLocked := Odd(GetKeyState(VK_CAPITAL));
SetOnPasswordCapsEvents;
end;
end;
procedure TNCREdit.DoExit;
begin
if FBlockCapsBalloonTip and (FIsCapsLocked) then
begin
FIsCapsLocked := False;
SetOnPasswordCapsEvents;
end;
inherited;
end;
procedure TNCREdit.KeyUp(var Key: Word; Shift: TShiftState);
begin
if Key = VK_CAPITAL then
FIsCapsLocked := not FIsCapsLocked;
SetOnPasswordCapsEvents;
inherited;
end;
procedure TNCREdit.SetOnPasswordCapsEvents;
begin
if FIsCapsLocked then
begin
if Assigned(FOnPasswordCapsLocked) and
((self.PasswordChar <> #0) or ( not FValuePasswordChrOnCaps)) then
begin
FOnPasswordCapsLocked(Self);
end;
end
else
begin
if Assigned(FOnPasswordCapsLocked) and
((self.PasswordChar <> #0) or ( not FValuePasswordChrOnCaps)) then
begin
FOnPasswordCapsFreed(Self);
end;
end;
end;
procedure TNCREdit.SetOnPasswordCapsFreed(const aValue: TNotifyEvent);
begin
FOnPasswordCapsFreed := aValue;
FBlockCapsBalloonTip := True;
end;
procedure TNCREdit.SetOnPasswordCapsLocked(const aValue: TNotifyEvent);
begin
FOnPasswordCapsLocked := aValue;
FBlockCapsBalloonTip := True;
end;
procedure TNCREdit.WndProc(var Message: TMessage);
begin
if (Message.Msg = EM_SHOWBALLOONTIP) and FBlockCapsBalloonTip then Exit;
inherited;
end;
end.
Mr Kobik made a very elegant piece of code that I think PasteBin should not be trusted to host, so I decided to add it here.
From what I understood it lets you handle TPasswordCapsLockState in one event handler that is fired when the TPasswordEdit receives focus, loses focus, CapsLock key pressed while on focus and an optional firing when PasswordChar is changed.
Using this approach I could use the OnPasswordCapsLock event to show/hide the image in my question instead of forcing the consumer of the component to use two event handlers for each state (very clever by the way and less error prone).
also as long as LNeedHandle := FBlockCapsBalloonTip and IsPassword; is True I have another added feature to TPasswordEdit which is the handling of OnEnter and OnExit in OnPasswordCapsLock as well,
So what can I say Mr Kobik Je vous tire mon chapeau.
type
TPasswordCapsLockState = (pcsEnter, pcsExit, pcsKey, pcsSetPasswordChar);
TPasswordCapsLockEvent = procedure(Sender: TObject;
Locked: Boolean; State: TPasswordCapsLockState) of object;
TPasswordEdit = class(TCustomEdit)
private
FIsCapsLocked: boolean;
FBlockCapsBalloonTip: boolean;
FOnPasswordCapsLock: TPasswordCapsLockEvent;
protected
procedure WndProc(var Message: TMessage); override;
procedure KeyUp(var Key: Word; Shift: TShiftState); override;
procedure DoEnter; override;
procedure DoExit; override;
procedure HandlePasswordCapsLock(State: TPasswordCapsLockState); virtual;
function GetIsPassword: Boolean; virtual;
public
property IsPassword: Boolean read GetIsPassword;
published
property BlockCapsBalloonTip: boolean read FBlockCapsBalloonTip write FBlockCapsBalloonTip default False;
//... The usual property declaration of TEdit
property OnPasswordCapsLock: TPasswordCapsLockEvent read FOnPasswordCapsLock write FOnPasswordCapsLock;
end;
implementation
function TPasswordEdit.GetIsPassword: Boolean;
begin
Result := ((PasswordChar <> #0) or
// Edit control can have ES_PASSWORD style with PasswordChar == #0
// if it was creaed with ES_PASSWORD style
(HandleAllocated and (GetWindowLong(Handle, GWL_STYLE) and ES_PASSWORD <> 0)));
end;
procedure TPasswordEdit.HandlePasswordCapsLock;
var
LNeedHandle: Boolean;
begin
LNeedHandle := FBlockCapsBalloonTip and IsPassword;
if LNeedHandle then
begin
FIsCapsLocked := Odd(GetKeyState(VK_CAPITAL));
if Assigned(FOnPasswordCapsLock) then
FOnPasswordCapsLock(Self, FIsCapsLocked, State);
end;
end;
procedure TPasswordEdit.DoEnter;
begin
inherited;
HandlePasswordCapsLock(pcsEnter);
end;
procedure TPasswordEdit.DoExit;
begin
inherited;
HandlePasswordCapsLock(pcsExit);
end;
procedure TPasswordEdit.KeyUp(var Key: Word; Shift: TShiftState);
begin
inherited;
if Key = VK_CAPITAL then
HandlePasswordCapsLock(pcsKey);
end;
procedure TPasswordEdit.WndProc(var Message: TMessage);
begin
if (Message.Msg = EM_SHOWBALLOONTIP) and FBlockCapsBalloonTip and IsPassword then
Exit;
// Optional - if password char was changed
if (Message.Msg = EM_SETPASSWORDCHAR) and Self.Focused then
HandlePasswordCapsLock(pcsSetPasswordChar);
inherited;
end;
I have Delphi 7 and now installed Delphi XE2.
I'm not really experienced with Design, VCL etc. but I would like to have a button (with Caption!) and a simple background image (PNG). I have 3 pictures of custom buttons (1 for click, 1 for mouseoff and 1 for mouseover). I have tried almost everything but I can't seem to find a way to have a simple button with caption in the middle and the images in the background. Please help.
PS.: The button should NOT visually go down on click (this is already in the png image.)
You might adapt this tiny component, no need to install for testing
Test
procedure TForm1.MyOnClick( Sender: TObject );
begin
ShowMessage( 'Hallo' );
end;
procedure TForm1.Button1Click( Sender: TObject );
begin
with TImageButton.Create( self ) do
begin
Parent := self;
Images := Imagelist1;
Index := 0;
HoverIndex := 1;
DownIndex := 2;
Caption := 'test';
OnClick := MyOnClick;
Width := Imagelist1.Width;
Height := Imagelist1.Height;
Font.Size := 12;
Font.Style := [fsBold];
end;
end;
And code
unit ImageButton;
// 2013 bummi
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
ExtCtrls, StdCtrls,ImgList;
Type
TState = (MouseIn, MouseOut, Pressed);
TImageButton = class(TGraphicControl)
private
FChangeLink:TChangeLink;
FImages: TCustomImageList;
FDownIndex: Integer;
FIndex: Integer;
FHoverIndex: Integer;
FState: TState;
FCaption: String;
FOwner: TComponent;
FAutoWidth: Boolean;
procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
procedure WMLBUTTONDOWN(var Message: TMessage); message WM_LBUTTONDOWN;
procedure WMLBUTTONUP(var Message: TMessage); message WM_LBUTTONUP;
procedure SetDownIndex(const Value: Integer);
procedure SetHoverIndex(const Value: Integer);
procedure SetIndex(const Value: Integer);
procedure SetImages(const Value: TCustomImageList);
procedure SetCaption(const Value: String);
procedure ImagelistChange(Sender: TObject);
procedure SetAutoWidth(const Value: Boolean);
procedure CheckAutoWidth;
protected
procedure Paint; override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; Override;
published
property AutoWidth:Boolean read FAutoWidth Write SetAutoWidth;
property Caption;
property DownIndex: Integer read FDownIndex Write SetDownIndex;
property Font;
property HoverIndex: Integer read FHoverIndex Write SetHoverIndex;
property Images: TCustomImageList read FImages write SetImages;
property Index: Integer read FIndex Write SetIndex;
End;
procedure Register;
implementation
procedure TImageButton.ImagelistChange(Sender:TObject);
begin
invalidate;
CheckAutoWidth;
end;
Constructor TImageButton.create(AOwner: TComponent);
begin
inherited Create(AOwner);
FOwner := AOwner;
FState := MouseOut;
Width := 200;
Height := 200;
FChangeLink:=TChangeLink.Create;
FChangeLink.OnChange := ImagelistChange;
end;
Destructor TImageButton.Destroy;
begin
if Assigned(FImages) then FImages.UnRegisterChanges(FChangeLink);
FChangeLink.Free;
inherited Destroy;
end;
procedure TImageButton.Paint;
var
ico: TIcon;
idx: Integer;
DestRect: TRect;
L_Caption: String;
begin
inherited;
idx := -1;
if Assigned(FImages) then
begin
case FState of
MouseIn:
if FImages.Count > HoverIndex then
idx := HoverIndex;
MouseOut:
if FImages.Count > Index then
idx := Index;
Pressed:
if FImages.Count > DownIndex then
idx := DownIndex;
end;
if idx > -1 then
try
ico := TIcon.create;
FImages.GetIcon(idx, ico);
Canvas.Draw(0, 0, ico);
finally
ico.Free;
end;
end
else
begin
Canvas.Rectangle(ClientRect);
end;
Canvas.Brush.Style := bsClear;
DestRect := ClientRect;
L_Caption := Caption;
Canvas.Font.Assign(Font);
Canvas.TextRect(DestRect, L_Caption, [tfVerticalCenter, tfCenter, tfSingleLine]);
end;
procedure TImageButton.CheckAutoWidth;
begin
if FAutoWidth and Assigned(FImages) then
begin
Width := FImages.Width;
Height := FImages.Height;
end;
end;
procedure TImageButton.SetAutoWidth(const Value: Boolean);
begin
FAutoWidth := Value;
CheckAutoWidth;
end;
procedure TImageButton.SetCaption(const Value: String);
begin
FCaption := Value;
Invalidate;
end;
procedure TImageButton.SetDownIndex(const Value: Integer);
begin
FDownIndex := Value;
Invalidate;
end;
procedure TImageButton.SetHoverIndex(const Value: Integer);
begin
FHoverIndex := Value;
Invalidate;
end;
procedure TImageButton.SetImages(const Value: TCustomImageList);
begin
if Assigned(FImages) then FImages.UnRegisterChanges(FChangeLink);
FImages := Value;
if Assigned(FImages) then
begin
FImages.RegisterChanges(FChangeLink);
FImages.FreeNotification(FOwner);
CheckAutoWidth;
end;
Invalidate;
end;
procedure TImageButton.SetIndex(const Value: Integer);
begin
FIndex := Value;
Invalidate;
end;
procedure TImageButton.WMLBUTTONDOWN(var Message: TMessage);
begin
inherited;
FState := Pressed;
Invalidate;
end;
procedure TImageButton.WMLBUTTONUP(var Message: TMessage);
begin
inherited;
FState := MouseIn;
Invalidate;
end;
procedure TImageButton.CMFontChanged(var Message: TMessage);
begin
Invalidate;
end;
Procedure TImageButton.CMMouseEnter(var Message: TMessage);
Begin
inherited;
if (csDesigning in ComponentState) then
Exit;
if FState <> MouseIn then
begin
FState := MouseIn;
Invalidate;
end;
end;
Procedure TImageButton.CMMouseLeave(var Message: TMessage);
Begin
inherited;
if (csDesigning in ComponentState) then
Exit;
if FState <> MouseOut then
begin
FState := MouseOut;
Invalidate;
end;
end;
procedure TImageButton.CMTextChanged(var Message: TMessage);
begin
invalidate;
end;
procedure Register;
begin
RegisterComponents('Own', [TImageButton])
end;
end.
Will respect transparencies if use with PNG and Imagelist cd32Bit
You can inherit from TBitBtn and override CN_DRAWITEM message handler - this will create a fully normal button with focus,with any pictures you need as a background and with all window messages that buttons need (see BM_XXX messages). You can also implement a virtual method to do other kinds of buttons with just this method overriden.
Something like that:
TOwnerDrawBtn = class(TBitBtn)
private
procedure CNDrawItem(var Message: TWMDrawItem); message CN_DRAWITEM;
procedure CMFocusChanged(var Message: TMessage); message CM_FOCUSCHANGED;
protected
procedure DrawButton(const DrawItemStruct: TDrawItemStruct); virtual;
end;
procedure TOwnerDrawBtn.CNDrawItem(var Message: TWMDrawItem);
begin
DrawButton(Message.DrawItemStruct^);
Message.Result := Integer(True);
end;
procedure TOwnerDrawBtn.CMFocusChanged(var Message: TMessage);
begin
inherited;
Invalidate;
end;
procedure TOwnerDrawBtn.DrawButton(const DrawItemStruct: TDrawItemStruct);
var
Canvas: TCanvas;
begin
Canvas := TCanvas.Create;
try
Canvas.Handle := DrawItemStruct.hDC;
//do any drawing here
finally
Canvas.Handle := 0;
Canvas.Free;
end;
end;
You Can Simply Use TJvTransparentButton from JEDI-Project JVCL .
With this component you can use single imagelist for all events and all other buttons , more events with image state , more style, Caption , Glyph, PressOffset and ... .
This question is unlikely to help any future visitors; it is only relevant to a small geographic area, a specific moment in time, or an extraordinarily narrow situation that is not generally applicable to the worldwide audience of the internet. For help making this question more broadly applicable, visit the help center.
Closed 10 years ago.
Hi I'm trying to build an TEdit control with TButton to have Buttoned Edit but the problem is that the text clip gets under the Button and some latter doesn't appear because the button is over it. how to fix that? please note that when I call UpdateEditMargins (which is the procedure to adjust the text clip)
Here is my code:
unit YazButtonedEdit;
interface
uses
SysUtils, Classes, Controls, StdCtrls, Buttons, Messages, Windows, Forms;
type
TYazButtonedEdit = class(TCustomEdit)
private
FEditButton: TBitBtn;
FButtonWidth: Integer;
FButtonVisible: Boolean;
procedure WMSize(var Message: TMessage); message WM_SIZE;
procedure SetButtonVisible(const Value: Boolean);
procedure GetEditButtonClick(const Value: TNotifyEvent);
function SetEditButtonClick: TNotifyEvent;
procedure SetButtonWidth(const Value: Integer);
protected
procedure RefreshButton;
procedure CreateParams(var Params: TCreateParams); override;
procedure WndProc(var Message: TMessage); override;
public
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure UpdateEditMargins;
published
property ButtonWidth: Integer read FButtonWidth write SetButtonWidth;
property ButtonVisible: Boolean read FButtonVisible write SetButtonVisible;
property OnEditButtonClick: TNotifyEvent read SetEditButtonClick write GetEditButtonClick;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('KH-Controls', [TYazButtonedEdit]);
end;
{ TYazButtonedEdit }
constructor TYazButtonedEdit.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
ControlStyle := ControlStyle - [csSetCaption];
FEditButton := TBitBtn.Create(self);
with FEditButton do begin
Parent := self;
TabStop := false;
Visible := true;
OnClick := OnEditButtonClick;
end;
end;
procedure TYazButtonedEdit.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
Params.Style := Params.Style or WS_CLIPCHILDREN;
end;
destructor TYazButtonedEdit.Destroy;
begin
FEditButton.Free;
inherited;
end;
procedure TYazButtonedEdit.GetEditButtonClick(const Value: TNotifyEvent);
begin
FEditButton.OnClick := Value;
end;
procedure TYazButtonedEdit.RefreshButton;
begin
FEditButton.Width := ButtonWidth;
FEditButton.Height := Height - 4;
FEditButton.Visible := ButtonVisible;
UpdateEditMargins;
end;
procedure TYazButtonedEdit.SetButtonVisible(const Value: Boolean);
begin
if FButtonVisible <> Value then
begin
FButtonVisible := Value;
RefreshButton;
end;
end;
procedure TYazButtonedEdit.SetButtonWidth(const Value: Integer);
begin
if FButtonWidth <> Value then
begin
FButtonWidth := Value;
RefreshButton;
end;
end;
function TYazButtonedEdit.SetEditButtonClick: TNotifyEvent;
begin
Result := FEditButton.OnClick;
end;
procedure TYazButtonedEdit.WMSize(var Message: TMessage);
begin
RefreshButton;
end;
procedure TYazButtonedEdit.WndProc(var Message: TMessage);
var
LLeft, LTop: Integer;
begin
case Message.Msg of
CN_CTLCOLORSTATIC,
CN_CTLCOLOREDIT:
if FEditButton.Visible then
begin
LLeft := FEditButton.Left;
LTop := FEditButton.Top;
ExcludeClipRect(Message.WParam, LLeft + 1, LTop + 1,
FEditButton.Width + FEditButton.Left - 1, FEditButton.Height - 1);
end;
end;
inherited;
end;
procedure TYazButtonedEdit.UpdateEditMargins;
var
LMargin, RMargin: Integer;
begin
if HandleAllocated then
begin
LMargin := 0;
RMargin := 0;
if FEditButton.Visible then
LMargin := FEditButton.Width + 2;
SendMessage(Handle, EM_SETMARGINS, EC_LEFTMARGIN or EC_RIGHTMARGIN, MakeLong(LMargin, RMargin));
Invalidate;
end;
end;
procedure TYazButtonedEdit.Notification(AComponent: TComponent; Operation: TOperation);
begin
inherited Notification(AComponent, Operation);
if Operation = opRemove then
begin
if AComponent = FEditButton then
begin
RefreshButton;
end;
end;
end;
end.
Call it after the edit window is created, ideally in CreateWnd method. So, add the following:
type
TYazButtonedEdit = class(TCustomEdit)
...
protected
procedure CreateWnd; override;
...
end;
implementation
procedure TYazButtonedEdit.CreateWnd;
begin
inherited;
UpdateEditMargins;
end;
Strictly for use in the reserved address ranges, so IPv4 is good enough. I don't know yet if I will use class A, B or C (probably C, but ...) so it would be a bonus to be able to handle all.
And extra bonus if I can also enter something like "localhost", although I can live without that.
So, minimum requirement is to specify a 192.xxx.xxx.xxx and make sure that xxx does not exceed 255.
Sure, I could knock one up with a few mask edits, but surely someone has invented that particular (FOSS) wheel before?
Note to self: if you do have to code it, this page looks useful
Windows has a built-in IP Address edit control. You can wrap that in a custom TWinControl descendant component for easy access and reuse, eg:
type
TIPAddressFieldChange = procedure(Sender: TObject; Field: Integer; Value: Integer) of object;
TIPAddress = class(TWinControl)
private
FOnFieldChange: TIPAddressFieldChange;
function GetIP: String;
function GetIsEmpty: Boolean;
procedure SetIP(const Value: String);
protected
procedure CreateParams(var Params: TCreateParams); override;
procedure CNNotify(var Message: TWMNotify); message CN_NOTIFY;
procedure WMGetDlgCode(var Message: TMessage); message WM_GETDLGCODE;
procedure WMSetFont(var Message: TWMSetFont); message WM_SETFONT;
public
constructor Create(Owner: TComponent); override;
procedure Clear;
property IP: String read GetIP write SetIP;
property IsEmpty: Boolean read GetIsEmpty;
published:
property OnFieldChange: TIPAddressFieldChange read FOnFieldChange write FOnFieldChange;
end;
.
uses
Commctrl;
constructor TIPAddress.Create(Owner: TComponent);
begin
inherited;
InitCommonControl(ICC_INTERNET_CLASSES};
end;
procedure TIPAddress.CreateParams(var Params: TCreateParams);
begin
inherited;
CreateSubClass(Params, WC_IPADDRESS);
Params.Style := WS_CHILD or WS_TABSTOP or WS_VISIBLE;
if NewStyleControls and Ctl3D then
begin
Params.Style := Params.Style and not WS_BORDER;
Params.ExStyle := Params.ExStyle or WS_EX_CLIENTEDGE;
end;
Params.WindowClass.style := Params.WindowClass.style and not (CS_HREDRAW or CS_VREDRAW);
end;
procedure TIPAddress.Clear;
begin
Perform(IPM_CLEARADDRESS, 0, 0);
end;
function TIPAddress.GetIP: String;
var
dwIp: DWORD;
begin
dwIp := 0;
Perform(IPM_GETADDRESS, 0, LPARAM(#dwIp));
Result := Format('%d.%d.%d.%d', [FIRST_IPADDRESS(dwIp), SECOND_IPADDRESS(dwIp),
THIRD_IPADDRESS(dwIp), FOURTH_IPADDRESS(dwIp)]);
end;
function TIPAddress.GetIsEmpty: Boolean;
begin
Result := Perform(IPM_ISBLANK, 0, 0) <> 0;
end;
procedure TIPAddress.SetIP(const Value: String);
var
dwIP: LPARAM;
begin
with TStringList.Create do try
Delimiter := '.';
StrictDelimiter := True;
DelimitedText := Value;
Assert(Count = 4);
dwIP := MAKEIPADDRESS(StrToInt(Strings[0]), StrToInt(Strings[1]), StrToInt(Strings[2]), StrToInt(Strings[3]));
finally
Free;
end;
Perform(IPM_SETADDRESS, 0, dwIP);
end;
procedure TIPAddress.CNNotify(var Message: TWMNotify);
begin
inherited;
if (Message.NMHdr^.code = IPN_FIELDCHANGED) and Assigned(FOnFieldChange) then
begin
with PNMIPAddress(Message.NMHdr)^ do
FOnFieldChange(Self, iField, iValue);
end;
end;
procedure TIPAddress.WMGetDlgCode(var Message: TMessage);
begin
inherited;
Message.Result := Message.Result or DLGC_WANTARROWS;
end;
procedure TIPAddress.WMSetFont(var Message: TWMSetFont);
var
LF: LOGFONT;
begin
if GetObject(Message.Font, SizeOf(LF), #LF) <> 0 then
begin
Message.Font := CreateFontIndirect(LF);
inherited;
end;
end;
What about to try the TJvIPAddress from the JEDI Visual Component Library ? It has the automatic range value correction and it derives from the standard Windows IP edit box.