Aquí esta recien salido del horno, pongo el código completo, espero os guste y quedo a la espera de las correciones que hagais
Código Delphi
[-]
unit ScreenColorFontZoomCenter;
interface
uses
Windows, ExtCtrls, Messages,SysUtils, Classes, Graphics,
StdCtrls, ComCtrls, Controls, Forms, TypInfo, Dialogs ;
type
TVZoomVal = 1..4;
TCenterScreenColorFontZoom = class(TComponent)
private
FActive: Boolean; FTag: integer; FColorActive: Boolean; FColorConFoco: TColor; FColorSinFoco: TColor; FPierdeFoco, FTieneFoco: TWinControl; FForm: Boolean; FColorForm: TColor; FTagValorAdmit: Integer; FZoomActive: Boolean; FZoomVal: TVZoomVal; FFontActive :boolean; FFontProg: Boolean; FFontFocus: Tfont; FFontNoFocus: Tfont; FPanel: Boolean; FOnFocusChange: TNotifyEvent; procedure ScreenActiveControlChange(Sender: TObject);
protected
public
Procedure AplicarColor(Color: string; Componente: TWinControl);
constructor Create(AOwner : TComponent); override;
destructor Destroy; override;
published
property Active: boolean read FActive write FActive default False;
property Tag: integer read FTag write FTag;
property ColorConFoco: TColor read FColorConFoco write FColorConFoco;
property ColorSinFoco: TColor read FColorSinFoco write FColorSinFoco;
property ColorActive: boolean read FColorActive write FColorActive default True;
property Form: boolean read FForm write FForm default False;
property TagValorAdmit: integer read FTagValorAdmit write FTagValorAdmit default 0;
property ZoomActive: Boolean read FZoomActive write FZoomActive default False;
property ZoomVal: TVZoomVal read FZoomVal write FZoomVal default 1;
property FontActive: Boolean read FFontActive write FFontActive default False;
property FontProg: Boolean read FFontProg write FFontProg default False;
property PAnel: Boolean read FPanel write FPanel default False;
property FontFocus: TFont read FFontFocus write FFontFocus;
property FontNoFocus: TFont read FFontNoFocus write FFontNoFocus;
property OnFocusChange: TNotifyEvent read FOnFocusChange write FOnFocusChange;
end;
var VarCompUsage: Integer;
procedure Register;
implementation
const
csfsBold = '|Bold';
csfsItalic = '|Italic';
csfsUnderline = '|Underline';
csfsStrikeout = '|Strikeout';
procedure StringToFont( sFont : string; Font : TFont );
var
p : integer;
sStyle : string;
begin
with Font do
begin
p := Pos( ',', sFont );
Name := Copy( sFont, 2, p-3 );
Delete( sFont, 1, p );
p := Pos( ',', sFont );
Size := StrToInt( Copy( sFont, 2, p-2 ) );
Delete( sFont, 1, p );
p := Pos( ',', sFont );
sStyle := '|' + Copy( sFont, 3, p-4 );
Delete( sFont, 1, p );
Color := StringToColor( Copy( sFont, 3, Length( sFont ) - 3 ) );
Style := [];
if( Pos( csfsBold, sStyle ) > 0 )then Style := Style + [ fsBold ];
if( Pos( csfsItalic, sStyle ) > 0 )then Style := Style + [ fsItalic ];
if( Pos( csfsUnderline, sStyle ) > 0 )then Style := Style + [ fsUnderline ];
if( Pos( csfsStrikeout, sStyle ) > 0 )then Style := Style + [ fsStrikeout ];
end;
end;
function FontToString( Font : TFont ) : string;
var
sStyle : string;
begin
with Font do
begin
sStyle := '';
if( fsBold in Style )then sStyle := sStyle + csfsBold;
if( fsItalic in Style )then sStyle := sStyle + csfsItalic;
if( fsUnderline in Style )then sStyle := sStyle + csfsUnderline;
if( fsStrikeout in Style )then sStyle := sStyle + csfsStrikeout;
if( ( Length( sStyle ) > 0 ) and ( '|' = sStyle[ 1 ] ) )then
begin
sStyle := Copy( sStyle, 2, Length( sStyle ) - 1 );
end;
Result := Format( '"%s", %d, [%s], [%s]', [ Name, Size, sStyle, ColorToString( Color ) ] );
end;
end;
function ExistProp(Instance: TObject; const PropName: string):Boolean;
var
PropInfo: PPropInfo;
begin
PropInfo := GetPropInfo(Instance, PropName);
Result := not (PropInfo = nil);
end;
function SetPropAsString(AObj: TObject; const PropName, Value: String):Boolean;
var
PInfo: PPropInfo;
Begin
PInfo := GetPropInfo(AObj.ClassInfo, PropName);
Result := PInfo <> nil;
if (Result) then
begin
if (PInfo^.Proptype^.Kind = tkString) or (PInfo^.Proptype^.Kind = tkLString) then
begin
SetStrProp(AObj, PInfo, Value);
end else
if (PInfo^.Proptype^.Kind = tkInteger) then
begin
if (PInfo^.PropType^.Name = 'TColor') then
begin
SetOrdProp(AObj, PInfo, StringToColor(Value));
end else
begin
SetOrdProp(AObj, PInfo, StrToInt(Value));
end;
end else
begin
Result := False;
MessageDlg('''La propiedad '' + PropName + '' no es de tipo String (o un tipo implementado)', mtWarning, [mbOK], 0);
end;
end else
begin
Result := False;
end;
end;
procedure Register;
begin
RegisterComponents('Samples', [TCenterScreenColorFontZoom]);
end;
constructor TCenterScreenColorFontZoom.Create(AOwner : TComponent);
begin
inherited Create(AOwner);
Screen.OnActiveControlChange := ScreenActiveControlChange;
FColorConFoco := clSkyBlue;
FColorSinFoco := clWindow;
FColorActive:= True;
FTagValorAdmit:=0;
FForm :=False;
FActive:=False;
FZoomActive:= False;
FZoomVal:=1;
FFontActive:=False;
FFontProg:=False;
FFontFocus:=TFont.Create;
FFontNoFocus:=TFont.Create;
FPanel:=False;
VarCompUsage:=0;
end;
destructor TCenterScreenColorFontZoom.Destroy;
begin
Screen.OnActiveControlChange := nil;
FFontNoFocus.Free();
FFontFocus.Free();
inherited;
end;
procedure TCenterScreenColorFontZoom.ScreenActiveControlChange(Sender: TObject);
begin
FPierdeFoco := FTieneFoco;
FTieneFoco := Screen.ActiveControl;
if FActive=True then
begin
if not ((Screen.ActiveControl.ClassType = TForm) and (FForm=False)) then
begin
if FPierdeFoco <> nil then begin
if FPierdeFoco.Tag=FTagValorAdmit then
begin
if not ((FPierdeFoco.ClassType=TPanel) and (FPanel=False)) then
begin
if FColorActive=true then Self.AplicarColor(ColorToString(FColorSinFoco), FPierdeFoco);
if FZoomActive = true then
begin TEdit(FPierdeFoco).Font.Size:=(Tedit(FPierdeFoco).Font.Size div Fzoomval);
FPierdeFoco.Width:=(FPierdeFoco.Width div FZoomVal);
end;
if FFontActive=true then TEdit(FPierdeFoco).font:=FFontNoFocus;
end;
VarCompUsage:=0; end;
end;
if FTieneFoco <> nil then begin
if FTieneFoco.Tag=FTagValorAdmit then
begin
if not ((FTieneFoco.ClassType=TPanel) and (FPanel=False)) then
begin
if FColorActive=true then self.AplicarColor(ColorToString(FColorconFoco), FTieneFoco);
if FFontActive=true then
begin
if FFontProg=true then FFontNoFocus:=TEdit(FTieneFoco).Font;
TEdit(FTieneFoco).Font:=FFontFocus;
end;
if FZoomActive = true then
begin TEdit(FTieneFoco).Font.Size:=(Tedit(FTieneFoco).Font.Size * Fzoomval);
FTieneFoco.Width:=(FTieneFoco.Width * FZoomVal);
FTieneFoco.BringToFront;
end;
FTag := self.Tag;
VarCompUsage:=1; end;
end;
end else FTag := 0;
end;
end else
begin
if (VarCompUsage=1) then begin
if FPierdeFoco.Tag=FTagValorAdmit then
begin
if not ((FPierdeFoco.ClassType=TPanel) and (FPanel=False)) then
begin
if FColorActive=true then Self.AplicarColor(ColorToString(FColorSinFoco), FPierdeFoco);
if FZoomActive = true then
begin TEdit(FPierdeFoco).Font.Size:=(Tedit(FPierdeFoco).Font.Size div Fzoomval);
FPierdeFoco.Width:=(FPierdeFoco.Width div FZoomVal);
end;
if FFontActive=true then TEdit(FPierdeFoco).font:=FFontNoFocus;
end;
end;
VarCompUsage:=0; end;
FTag:=0;
end;
if Assigned(FOnFocusChange) then FOnFocusChange(Self);
end;
Procedure TCenterScreenColorFontZoom.AplicarColor(Color :String; Componente: TWinControl);
begin
try
if ExistProp(Componente,'Color') then SetPropAsString(Componente,'Color',Color);
except
end;
end;
end.
Espero que este al nivel adecuado y este lo suficientemente dosumentado.