Label component

Her er en komponent som arver fra TWinControl. Den kan dog sagtens gøres mindre/smartere (jeg har nogle funktioner som bare kalder direkte den nedarede funktion).

Den tegner en XP button (sådan nogenlunde) men resten må du selv sidde og lege med.


unit LabelEx;

interface

uses
Classes,
Windows,
Controls,
Messages,
Graphics,
StdCtrls;

type
TMyLabelState = (mlsOver, mlsDown, mlsUp, mlsFocused);
TMyLabelStates = set of TMyLabelState;
TMyLabelOnEnter = procedure(Sender : TObject; X, Y : Integer) of object;
TMyLabelOnExit = TMyLabelOnEnter;
TMyLabel = class(TWinControl)
private
FCanvas : TCanvas;
FCapture : HWND;
FIsCaptured : Boolean;
FOnEnter : TMyLabelOnEnter;
FOnExit : TMyLabelOnExit;
FBorder : TColor;
FTxtColor : TColor;
FBGColor : TColor;
FSelectColor: TColor;
FState : TMyLabelStates;
protected
procedure CaptureMouse;
procedure ReleaseMouse;

procedure Notification(AComponent: TComponent; Operation: TOperation); override;
procedure Loaded; override;
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure DoEnter; override;
procedure DoExit; override;
procedure WMPaint(var Msg : TWMPaint); message WM_PAINT;
procedure WMEraseBkgnd(var Message: TWmEraseBkgnd); message WM_ERASEBKGND;
procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
procedure WMWindowPosChanged(var Message: TWMWindowPosChanged); message WM_WINDOWPOSCHANGED;

procedure Paint(Canvas : TCanvas);
procedure PaintWindow(DC: HDC); override;
procedure CreateWnd; override;
public
constructor Create(AOwner : TComponent); override;
destructor Destroy; override;
published
property TabOrder;
property TabStop;
property OnEnter : TMyLabelOnEnter read FOnEnter write FOnEnter;
property OnExit : TMyLabelOnExit read FOnExit write FOnExit;
property BorderColor : TColor read FBorder write FBorder;
property TextColor : TColor read FTxtColor write FTxtColor;
property BGColor : TColor read FBGColor write FBGColor;
property BGSelectColor : TColor read FSelectColor write FSelectColor;
property Caption;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnClick;
end;

procedure Register;

implementation

uses
SysUtils;

constructor TMyLabel.Create(AOwner : TComponent);
var
S : TControlStyle;
begin
inherited Create(AOwner);
FCapture := 0;
FIsCaptured := False;
FOnEnter := nil;
FOnExit := nil;
FBGColor := RGB(243, 243, 239);
FTxtColor := clBlack;
FBorder := RGB(105,130,238);
FSelectColor := RGB(248, 179, 48);
FCanvas := TCanvas.Create;
FState := [];
S := ControlStyle;
Include(S, csClickEvents);
DoubleBuffered := True;
end;

destructor TMyLabel.Destroy;
begin
FCanvas.Free;
ReleaseMouse;
FOnEnter := nil;
FOnExit := nil;
inherited Destroy;
end;

procedure TMyLabel.CreateWnd;
var
RGN : HRGN;
begin
inherited CreateWnd;
RGN := CreateRoundRectRgn(0, 0, Width, Height, 6, 6);
SetWindowRgn(Handle, RGN, True);
end;

procedure TMyLabel.CaptureMouse;
begin
if not FIsCaptured then
begin
FIsCaptured := True;
FCapture := Mouse.Capture;
Mouse.Capture := Handle;
end;
end;

procedure TMyLabel.ReleaseMouse;
begin
if FIsCaptured then
begin
FIsCaptured := False;
Mouse.Capture := FCapture;
FCapture := 0;
end;
end;

procedure TMyLabel.Paint(Canvas : TCanvas);
var
RGN : TRect;
X,Y : Integer;
begin
RGN := Rect(0, 0, Width, Height);
Canvas.Pen.Color := FBorder;
Canvas.Pen.Width := 1;
Canvas.Brush.style := bsSolid;
Canvas.Brush.Color := FBGColor;
Canvas.Font := Font;
Canvas.Font.Color := FTxtColor;
X := (Width - Canvas.TextWidth(Caption)) div 2;
Y := (Height - Canvas.TextHeight(Caption)) div 2;
if mlsDown in FState then
Canvas.TextRect(RGN,X+1, Y+1, Caption)
else
Canvas.TextRect(RGN, X, Y, Caption);

Canvas.Brush.style := bsClear;
if mlsOver in FState then
begin
Canvas.Pen.Color := FSelectColor;
Canvas.Pen.Width := 3;
Canvas.RoundRect(1, 1, Width-2, Height-2, 8, 8);
end
else
begin
if mlsFocused in FState then
begin
Canvas.Pen.Color := FBorder;
Canvas.Pen.Width := 3;
Canvas.RoundRect(1, 1, Width-2, Height-2, 8, 8);
end
end;
Canvas.Pen.Width := 1;
Canvas.Pen.Color := clBlack;
Canvas.RoundRect(0, 0, Width-1, Height-1, 8, 8);
end;

procedure TMyLabel.PaintWindow(DC : HDC);
begin
FCanvas.Lock;
try
FCanvas.Handle := DC;
try
Paint(FCanvas);
finally
FCanvas.Handle := 0;
end;
finally
FCanvas.Unlock;
end;
end;

procedure TMyLabel.WMPaint(var Msg : TWMPaint);
var
PS : TPaintStruct;
begin
BeginPaint(Handle, PS);
PaintWindow(PS.hdc);
EndPaint(Handle, PS);
end;

procedure TMyLabel.WMWindowPosChanged(var Message: TWMWindowPosChanged);
var
RGN : HRGN;
begin
inherited;
RGN := CreateRoundRectRgn(0, 0, Width, Height, 6, 6);
SetWindowRgn(Handle, RGN, True);
end;

procedure TMyLabel.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
inherited;
end;

procedure TMyLabel.CMTextChanged(var Message: TMessage);
begin
Invalidate;
end;

procedure TMyLabel.CMFontChanged(var Message: TMessage);
begin
inherited;
end;

procedure TMyLabel.Notification(AComponent: TComponent; Operation: TOperation);
begin
if (AComponent = Self) and (Operation = opRemove) and (FIsCaptured) then
ReleaseMouse;
inherited Notification(AComponent, Operation);
end;

procedure TMyLabel.Loaded;
begin
inherited Loaded;
end;

procedure TMyLabel.MouseMove(Shift: TShiftState; X, Y: Integer);
var
O : TMyLabelStates;
begin
O := FState;
if (X >= 0) and (X < Width) and (Y >= 0) and (Y < Height) then
begin
if not FIsCaptured then
begin
CaptureMouse;
Include(FState, mlsOver);
if Assigned(FOnEnter) then
FOnEnter(Self, X, Y);
end;
end
else
begin
ReleaseMouse;
Exclude(FState, mlsOver);
if Assigned(FOnExit) then
FOnExit(Self, X, Y);
end;
inherited MouseMove(Shift, X, Y);
if O <> FState then
Repaint;
// invalidate;
end;

procedure TMyLabel.DoEnter;
begin
Include(FState, mlsFocused);
Repaint;
end;

procedure TMyLabel.DoExit;
begin
Exclude(FState, mlsFocused);
Repaint;
end;

procedure TMyLabel.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
Exclude(FState, mlsDown);
Include(FState, mlsUp);
ReleaseMouse;
Invalidate;
inherited MouseUp(Button, Shift, X, Y);
end;

procedure TMyLabel.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
Include(FState, mlsDown);
Exclude(FState, mlsUp);
Invalidate;
inherited MouseDown(Button, Shift, X, Y);
end;

procedure Register;
begin
RegisterComponents('Samples', [TMyLabel]);
end;

end.


God fornøjelse.

Mvh
Michael.

Jeg vil gerne lave et component baseret på TLabel, når jeg "opretter" et component med TLabel som grundsten får man jo en kode som giver et component som er pricist som TLabel...

Mit spørgsmål er så hvordan gør man så der sker et eller andet når componentet bliver oprettet på formen, og hvordan man gør så der sker noget når musen er over labelen, når musen forlader labelen, når musen er trykket ned og når musen går op

mvh.
Lasse Espeholt
webmaster for espeholt.dk

Hej Lasse,

Hvis du bygger din komponent på TStaticText (TWinControl) så får du events fra musen (OnMouseMove, OnMouseDown og OnMouseUp). Disse events kan du bruge til flere af dine ovenstående spørgsmål.

Jeg har skrevet en komponent som giver dig 3 ekstra events (OnInit, OnEnter og OnExit). De bliver kaldt når komponenten er loaded og når musen går ind over komponenten og når den forlader komponenten.

Jeg bruger "Mouse" variablen (ligger som en global variabel under Controls.pas) til at fange alle events fra musen til komponenten. Du kan dog også bruge Windows egne "GetCapture" og "SetCapture" funktioner.

For at besvare dine spørgsmål så skal du bruge "OnMouseUp" til at angive når brugeren har trykket på musen. "OnEnter" for at angive når brugeren har ført musen over komponenten og "OnExit" når den er fjernet fra komponenten. Du skal bruge OnInit til at angive hvornår du kan/bør sætte data.

Her er koden til komponenten:

unit MyLabel;

interface

uses
Classes,
Windows,
Controls,
StdCtrls;

type
TMyLabelOnEnter = procedure(Sender : TObject; X, Y : Integer) of object;
TMyLabelOnExit = TMyLabelOnEnter;
TMyLabelOnInit = procedure(Sender : TObject) of object;
TMyLabel = class(TStaticText)
private
FCapture : HWND;
FIsCaptured : Boolean;
FOnEnter : TMyLabelOnEnter;
FOnExit : TMyLabelOnExit;
FOnInit : TMyLabelOnInit;
protected
procedure CaptureMouse;
procedure ReleaseMouse;

procedure Notification(AComponent: TComponent; Operation: TOperation); override;
procedure Loaded; override;
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
public
constructor Create(AOwner : TComponent); override;
destructor Destroy; override;

property OnEnter : TMyLabelOnEnter read FOnEnter write FOnEnter;
property OnExit : TMyLabelOnExit read FOnExit write FOnExit;
property OnInit : TMyLabelOnInit read FOnInit write FOnInit;
end;

procedure Register;

implementation

uses
SysUtils;

constructor TMyLabel.Create(AOwner : TComponent);
begin
inherited Create(AOwner);
FCapture := 0;
FIsCaptured := False;
FOnEnter := nil;
FOnExit := nil;
FOnInit := nil;
end;

destructor TMyLabel.Destroy;
begin
ReleaseMouse;
FOnEnter := nil;
FOnExit := nil;
FOnInit := nil;
inherited Destroy;
end;

procedure TMyLabel.CaptureMouse;
begin
if not FIsCaptured then
begin
FIsCaptured := True;
FCapture := Mouse.Capture;
Mouse.Capture := Handle;
end;
end;

procedure TMyLabel.ReleaseMouse;
begin
if FIsCaptured then
begin
FIsCaptured := False;
Mouse.Capture := FCapture;
FCapture := 0;
end;
end;

procedure TMyLabel.Notification(AComponent: TComponent; Operation: TOperation);
begin
if (AComponent = Self) and (Operation = opRemove) and (FIsCaptured) then
ReleaseMouse;
inherited Notification(AComponent, Operation);
end;

procedure TMyLabel.Loaded;
begin
inherited Loaded;
if Assgined(FOnInit) then
FOnInit(Self);
end;

procedure TMyLabel.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
if (X >= 0) and (X < Width) and (Y >= 0) and (Y < Height) then
begin
if not FIsCaptured then
begin
CaptureMouse;
if Assigned(FOnEnter) then
FOnEnter(Self, X, Y);
end;
end
else
begin
ReleaseMouse;
if Assigned(FOnExit) then
FOnExit(Self, X, Y);
end;
inherited MouseMove(Shift, X, Y);
end;

procedure TMyLabel.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
ReleaseMouse;
inherited MouseUp(Button, Shift, X, Y);
end;

procedure Register;
begin
RegisterComponents('Additional', [TMyLabel]);
end;

end.


Håber det var det du skulle bruge,
Mvh
Michael.

Jeg tror ikke helt du forstår mig...

Jeg vil vide hvordan jeg i komponentet laver det der skal ske når man har musen overup, down over, create osv....

hvis du har msn kan vi lige prøve at snakke om det, mit msn er mysitesolution@hotmail.com

NEj jeg har fundet ud af det, men kan du ikke lige lave MouseDown fuktionen?

og en resize fuktion

og en resize fuktion

Hej,

Jeg kan sende dig en lille kode-stump som benytter din komponent.
Jeg kan dog først få det sendt i morgen tidlig.

Men hvad vil du med en resize funktion i en Label (Komponenten arver allerede fra TStaticText, som kan sørgefor at autosize'e hvis det er nødvendigt) ???

Mvh
Michael.

og en resize fuktion

Hej,

Jeg kan sende dig en lille kode-stump som benytter din komponent.
Jeg kan dog først få det sendt i morgen tidlig.

Men hvad vil du med en resize funktion i en Label (Komponenten arver allerede fra TStaticText, som kan sørgefor at autosize'e hvis det er nødvendigt) ???

Mvh
Michael.

Her er en Form som bruger TMyLabel komponenten:

unit LabelTest;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, LabelEx;

type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
private
FLabel : TMyLabel;
StaticText1: TStaticText;
procedure LabelEnter(Sender : TObject; X, Y : Integer);
procedure LabelExit(Sender : TObject; X, Y : Integer);
procedure LabelMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
procedure LabelMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
procedure LabelMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
public
end;

var
Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
begin
StaticText1 := TStaticText.Create(Self);
StaticText1.AutoSize := False;
StaticText1.Left := 20;
StaticText1.Top := 100;
StaticText1.Width := 120;
StaticText1.Height := 20;
StaticText1.Caption := 'None.';
InsertControl(StaticText1);

FLabel := TMyLabel.Create(Self);
FLabel.AutoSize := False;
FLabel.Left := 20;
FLabel.Top := 50;
FLabel.Width := 120;
FLabel.Height := 20;
FLabel.Caption := 'Start';
FLabel.OnEnter := LabelEnter;
FLabel.OnExit := LabelExit;
FLabel.OnMouseDown := LabelMouseDown;
FLabel.OnMouseMove := LabelMouseMove;
FLabel.OnMouseUp := LabelMouseUp;
InsertControl(FLabel);
end;

procedure TForm1.LabelEnter(Sender : TObject; X, Y : Integer);
begin
FLabel.Caption := 'Enter.';
end;

procedure TForm1.LabelExit(Sender : TObject; X, Y : Integer);
begin
FLabel.Caption := 'Exit.';
end;

procedure TForm1.LabelMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
StaticText1.Caption := 'MouseDown.';
end;

procedure TForm1.LabelMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
StaticText1.Caption := 'MouseMove.';
end;

procedure TForm1.LabelMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
StaticText1.Caption := 'MouseUp.';
end;

end.



Hvis det ikke er det du ville vide så skriv igen.

Mvh
Michael.

Jeg prøver....

Må jeg lige stille dig et spørgsmål???

Hvordan laver man om på TMyLabels udseende via noget canvas, det skal være indbygget i komponenten

Jeg prøver....

Må jeg lige stille dig et spørgsmål???

Hvordan laver man om på TMyLabels udseende via noget canvas, det skal være indbygget i komponenten

Selvfølgelig må du det.

Det kommer an på hvad du vil lave om (Farver, font type, font size, border eller??).
Hvis du fortæller mig helt nøjagtigt hvad det er du vil opnå så kan jeg hjælpe dig ud fra det.

Mvh
Michael.