Bueno espero si es posible que me ayuden. Hace tiempo vengo usando un componente que realice en VCL para delphi 2010 que consta de un rectángulo que cambia de color según tres estados como se muestra en la imagen anexa. Con tres campos adicionales gráficos en forma de texto y otros tres mas no gráficos.
- Estado ocupado: Color rojo;
- Estado libre: color gris claro;
- Estado seleccionado: color gis oscuro.
Realmente el componente funciona de maravilla para el cometido que le estaba dando, que es el control de puestos de estacionamientos.
El problema empieza al transformar el programa realizado hace unos 4 anos en VCL a FireMonkey para que pueda correr en MAC y Windowns. Tengo toda la programación lista de la base de datos, la conexión con el servidor remoto pero el componente principal no lo he podido transformar a FMX, tengo algún tiempo intentando pero no me sale nada.
Este es el código del componente realizado para VCL en Delphi.
unit uTPuestoVCL;
interface
uses
System.SysUtils,
System.Classes,
Vcl.Controls,
Vcl.Graphics,
Messages,
Windows,
System.AnsiStrings;
type
TMyState = (msLibre, msOcupado);
TPuesto = class(TCustomControl)
private
FId : Integer;
FPicture:TPicture;
FColors:array[0..6] of TColor;
FOnMouseEnter,
FOnMouseLeave:TNotifyEvent;
FBorder:Boolean;
FBorderWidth:Integer;
FOver:Boolean;
FPosXPicture:Word;
FText:TCaption;
FTextFont:TFont;
FPosXText:Word;
FAlignment,
FTextAlign: TAlignment;
{Texto Indicando el puesto}
FPuesto:String;
FPuestoFont:TFont;
FPuestoFontAlign:TAlignment;
{Status-delobjeto}
FState : TMyState;
FDataInicio:TDateTime;
FPlaca:String;
procedure SetPuesto(value:String);
function getPuesto:String;
procedure SetDataInicio(value:TDateTime);
function getDataInicio:TDateTime;
procedure SetPlaca(Value:String);
function getPlaca:String;
procedure SetId(Value:Integer);
//function getId(Valuer:Integer):Integer;
procedure SetPuestoFontAlign(Value: TAlignment);
procedure SetPuestoFont(Value:TFont);
procedure SetPicture(Value:TPicture);
procedure SetColors(Index:Integer;Value:TColor);
function GetColors(Index:integer):TColor;
procedure SetBorder(Value:Boolean);
procedure SetBorderWidth(Value:integer);
procedure SetPosXPicture(Value:Word);
procedure SetText(Value:TCaption);
procedure SetPosXText(Value:Word);
procedure SetTextFont(Value:TFont);
procedure FontChanged(Sender: TObject);
procedure SetAlignment(Value: TAlignment);
procedure SetTextAlign(Value: TAlignment);
procedure setState(Value:TMyState);
function getState:TMyState;
procedure setChangeStatus;
{ Private declarations }
protected
procedure WMSetFocus(var Message: TWMSetFocus); message WM_SETFOCUS;
procedure WMKillFocus(var Message: TWMSetFocus); message WM_KILLFOCUS;
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 Paint; override;
procedure KeyPress(var Key: Char);override;
procedure Click;override;
procedure DblClick;override;
{ Protected declarations }
public
constructor Create(AOwner:TComponent);override;
destructor Destroy;override;
property Colors[Index:Integer]:TColor read GetColors Write SetColors;
Procedure SetAllTexts(S:String);
{ Public declarations }
published
property FechaInicio:TDateTime read getDataInicio write SetDataInicio;
property Placa:String read getPlaca write setPlaca;
Property Status:TMyState read getState write setState default msLibre;
property Id:Integer read FId write SetId default 0;
property Alignment: TAlignment read FAlignment write SetAlignment default taLeftJustify;
property TextAlign: TAlignment read FTextAlign write SetTextAlign default taLeftJustify;
property Puesto:String read getPuesto write setPuesto;
property PuestoTextoAlign: TAlignment read FPuestoFontAlign write SetPuestoFontAlign default taCenter;
property PuestoTextFont:TFont read FPuestoFont Write SetPuestoFont;
property Picture:TPicture read FPicture Write SetPicture;
property Border:Boolean read FBorder Write SetBorder default True;
property BorderWidth:integer read FBorderWidth Write SetBorderWidth default 1;
property Color:TColor Index 0 read GetColors Write SetColors default clBtnFace;
property FocusedColor:TColor Index 2 read GetColors Write SetColors default clBtnHighlight;
property OverColor:TColor Index 4 read GetColors Write SetColors default clBtnShadow;
property ActiveColor:TColor Index 6 read GetColors Write SetColors default clRed;
property OverBorderColor:TColor Index 5 read GetColors Write SetColors default clBlack;
property BorderColor:TColor Index 1 read GetColors Write SetColors default clBlack;
property FocusedBorderColor:TColor Index 3 read GetColors Write SetColors default clBlack;
property PosXPicture:Word read FPosXPicture Write SetPosXPicture default 10;
property PosXText:Word read FPosXText Write SetPosXText default 10;
property Caption;
property Text:TCaption read FText Write SetText;
property TextFont:TFont read FTextFont Write SetTextFont;
property Font;
property Tabstop;
property BiDiMode;
property TabOrder;
property Action;
property Align;
property Anchors;
property Visible;
property Enabled;
property Constraints;
property DragCursor;
property DragKind;
property DragMode;
property ParentBiDiMode;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property ShowHint;
property OnMouseEnter:TNotifyEvent read FOnMouseEnter Write FOnMouseEnter;
property OnMouseLeave:TNotifyEvent read FOnMouseLeave Write FOnMouseLeave;
property OnClick;
property OnContextPopup;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEndDock;
property OnEndDrag;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnStartDock;
property OnStartDrag;
property OnEnter;
property OnExit;
{ Published declarations }
end;
Function _BiDiMode(Alignment: TAlignment;BiDi:TBiDiMode):TAlignment;
procedure Register;
implementation
Function _BiDiMode(Alignment: TAlignment;BiDi:TBiDiMode):TAlignment;
begin
Result :=Alignment;
if (SysLocale.MiddleEast) and (BiDi= bdRightToLeft) then
case Alignment of
taLeftJustify: Result := taRightJustify;
taRightJustify: result := taLeftJustify;
end;
end;
Procedure TPuesto.SetAllTexts(S:String);
begin
if S='' then
begin
Caption:='';
Text:='';
end
else
if pos('|',S)>0 then
begin
caption:=copy(S,1,pos('|',S)-1);
text:=copy(S,pos('|',S)+1,length(S));
end
else
Caption:=S;
end;
constructor TPuesto.Create(AOwner:TComponent);
begin
inherited;
Fid:=0;
FOver:=False;
Tabstop:=True;
FBorder:=True;
FBorderWidth:=1;
FColors[0]:= clBtnFace;
FColors[1]:=clBlack;
FColors[2]:=clBtnHighlight;
FColors[3]:=clBlack;
FColors[4]:= clBtnShadow;
FColors[5]:=clBlack;
FColors[6]:=clRed;
FPicture:=TPicture.Create;
FTextFont:=TFont.Create;
FTextFont.OnChange:=FontChanged;
FPosXPicture:=10;
FPosXText:=10;
FText:='';
Font.Style:=[fsBold];
FAlignment:=taCenter;
FTextAlign:=taCenter;
FPuestoFontAlign:=taCenter;
Puesto:=EmptyStr;
FPuestoFont:=TFont.Create;
FPuestoFont.OnChange:=FontChanged;
FPuestoFont.Style:=[fsBold];
ShowHint:=false;
FState:=msLibre;
end;
procedure TPuesto.DblClick;
begin
inherited;
setChangeStatus;
invalidate;
end;
destructor TPuesto.Destroy;
begin
FTextFont.Destroy;
FPicture.Destroy;
inherited;
end;
procedure TPuesto.CMTextChanged(var Message: TMessage);
begin
inherited;
invalidate;
end;
procedure TPuesto.WMSetFocus(var Message: TWMSetFocus);
begin
inherited;
Invalidate;
end;
procedure TPuesto.WMKillFocus(var Message: TWMSetFocus);
begin
inherited;
Invalidate;
end;
procedure TPuesto.CMMouseEnter(var Message: TMessage);
begin
inherited;
if Assigned(FOnMouseEnter) then FOnMouseEnter(Self);
FOver:=True;
Invalidate;
end;
procedure TPuesto.CMMouseLeave(var Message: TMessage);
begin
inherited;
if Assigned(FOnMouseLeave) then FOnMouseLeave(Self);
FOver:=False;
Invalidate;
end;
procedure TPuesto.SetPicture(Value:TPicture);
begin
FPicture.Assign(Value);
repaint;
end;
procedure TPuesto.SetPlaca(Value: String);
begin
if FPlaca<>Value then
begin
FPlaca:=Value;
Invalidate;
end;
end;
procedure TPuesto.SetPosXPicture(Value:Word);
begin
if FPosXPicture<>Value then
if value>0 then
begin
FPosXPicture:=Value;
invalidate;
end;
end;
procedure TPuesto.SetPosXText(Value:Word);
begin
if FPosXText<>Value then
if Value>0 then
begin
FPosXText:=Value;
invalidate;
end;
end;
procedure TPuesto.SetPuesto(value: String);
begin
if FPuesto<> value then
begin
FPuesto:=Value;
invalidate;
end;
end;
procedure TPuesto.SetPuestoFont(Value: TFont);
begin
FPuestoFont.Assign(Value);
end;
procedure TPuesto.SetPuestoFontAlign(Value: TAlignment);
begin
if FPuestoFontAlign<>Value then
begin
FPuestoFontAlign:=Value;
Invalidate;
end;
end;
procedure TPuesto.setState(Value: TMyState);
begin
if FState<>Value then
begin
FState:=Value;
invalidate;
end;
end;
procedure TPuesto.SetText(Value: TCaption);
begin
if FText<>Value then
begin
FText:=Value;
invalidate;
end;
end;
procedure TPuesto.SetTextFont(Value:TFont);
begin
FTextFont.Assign(Value);
end;
procedure TPuesto.FontChanged(Sender: TObject);
begin
invalidate;
end;
procedure TPuesto.SetBorder(Value:Boolean);
begin
if FBorder<>Value then
begin
FBorder:=Value;
Invalidate;
end;
end;
procedure TPuesto.SetBorderWidth(Value:integer);
begin
if FBorderWidth<>Value then
begin
if Value>0 then
FBorderWidth:=Value;
Invalidate;
end;
end;
procedure TPuesto.SetColors(Index:Integer;Value:TColor);
begin
if FColors[Index]<>Value then
begin
FColors[Index]:=Value;
Invalidate;
end;
end;
procedure TPuesto.SetDataInicio(value: TDateTime);
begin
if FDataInicio<>Value then
begin
FdataInicio:=Value;
invalidate;
end;
end;
procedure TPuesto.setId(Value: Integer);
begin
if Fid<>Value then
begin
FId:=Value;
Invalidate;
end;
end;
Function TPuesto.GetColors(Index:Integer):TColor;
begin
Result:=FColors[Index];
end;
function TPuesto.getDataInicio: TDateTime;
begin
result:=FDataInicio;
end;
function TPuesto.getPlaca: String;
begin
Result:=FPlaca;
end;
function TPuesto.getPuesto: String;
begin
result:=FPuesto;
end;
function TPuesto.getState: TMyState;
begin
Result:=FState;
end;
procedure TPuesto.Click;
begin
inherited;
SetFocus;
end;
procedure TPuesto.KeyPress(var Key: Char);
begin
if (Key=#13) or (Key=#32) then
Click;
Key:=#0;
end;
procedure TPuesto.SetAlignment(Value: TAlignment);
begin
if FAlignment<>Value then
begin
FAlignment:=Value;
Invalidate;
end;
end;
procedure TPuesto.SetTextAlign(Value: TAlignment);
begin
if FTextAlign<>Value then
begin
FTextAlign:=Value;
Invalidate;
end;
end;
procedure TPuesto.Paint;
const
AAlignment : array[taLeftJustify..taCenter] of uchar=(DT_LEFT,DT_RIGHT,DT_CENTER);
var
X, Y, W, H: Integer;
r:TRect;
Flags:Cardinal;
despv:Integer;
bmp: TBitmap;
pic_empty: TBitmap;
texto:String;
begin
despv:=3;
if border then
begin
despv:=despv+BorderWidth;
//Desph:=BorderWidth-1;
end;
with Canvas do
begin
setbkmode(Handle,TRANSPARENT);
Pen.Width:=BorderWidth;
Pen.Color:=BorderColor;
Brush.Style:=bsSolid;
Brush.Color:=Color;
X := Pen.Width div 2;
Y := X;
W := Width - Pen.Width + 1;
H := Height - Pen.Width + 1;
if FOver then
begin
Pen.Color:=OverBorderColor;
Brush.Color:=OverColor;
end;
FillRect(ClientRect);
Brush.Style:=bsClear;
if Border then Rectangle(X, Y, X + W, Y + H);
if Status = msOcupado then
begin
Brush.Color:=ActiveColor;
if FOver then
begin
Pen.Color:=OverBorderColor;
Brush.Color:=OverColor;
end;
//Brush.Style:=bsClear;
FillRect(ClientRect);
if Border then Rectangle(X, Y, X + W, Y + H);
if Assigned(Picture.Graphic) then
begin
Picture.Graphic.Transparent:=true;
Draw(0,0,Picture.Graphic);
end;
Hint:='Место: '+Puesto+chr(13)+'Клиент: '+Text+chr(13)+'Ном. Машины: '
+Placa+chr(13) +'Статус: Занято';
ShowHint:=true;
Flags:=AAlignment[_BiDiMode(Alignment,BiDiMode)] or DT_NOPREFIX or DT_END_ELLIPSIS;
Font:=self.Font;
R:=Rect(despv,despv,width-despv,TextHeight(Placa)+despv);
Drawtext(handle,PChar(Placa),-1,R,flags);
Flags:=AAlignment[_BiDiMode(FPuestoFontAlign,BiDiMode)] or DT_NOPREFIX or DT_END_ELLIPSIS;
Font:=self.FPuestoFont;
R:=Rect(despv,(Height div 2)-(TextHeight(caption) div 2), Width-despv, (Height div 2)+(TextHeight(caption) div 2));
DrawText(Handle, PChar(caption), -1, R, Flags);
Flags:=AAlignment[_BiDiMode(TextAlign,BiDiMode)] or DT_NOPREFIX or DT_END_ELLIPSIS;
Font:=self.TextFont;
R:=Rect(despv,height-despv-TextHeight(Text),width-despv,height-despv);
DrawText(Handle, PChar(Text), -1, R, Flags);
end else begin
texto:='Место: '+Puesto+chr(13)+'Статус: Свободно';
Hint:=Texto;
Placa:=EmptyStr;
Text:=EmptyStr;
FDataInicio:=-693594;
Flags:=AAlignment[_BiDiMode(FPuestoFontAlign,BiDiMode)] or DT_NOPREFIX or DT_END_ELLIPSIS;
Font:=self.FPuestoFont;
R:=Rect(despv,(Height div 2)-(TextHeight(caption) div 2), Width-despv, (Height div 2)+(TextHeight(caption) div 2));
DrawText(Handle, PChar(caption), -1, R, Flags);
end;
end;
end;
procedure Register;
begin
RegisterComponents('Estacionamiento', [TPuesto]);
end;
end.
Al rescribir el componente he realizado varias lineas de código pero no se como hacer uso de las canvas en FMX.
unit FMX.TPuesto;
interface
uses
System.Classes,
System.UITypes,
FMX.Types,
FMX.Controls,
FMX.Objects,
FMX.Graphics;
const
ColorOver = TAlphaColors.Gray;
ColorOcupado = TAlphaColors.Red;
ColorLibre = TAlphaColors.Gainsboro;
type
TPuesto = class(TRectangle)
private
{Data}
FId: Integer;
FPlaca: String;
FPuesto: String;
FCliente: String;
FStatus: Boolean;
FPoints: TFPoint;
{funciones y procedimientos relacionados con data}
procedure setId(const Valor: Integer);
procedure setPlaca(const Valor: String);
procedure setPuesto(const Valor: String);
procedure setCliente(const Valor: String);
procedure setStatus(const Valor: boolean);
protected
procedure Paint; override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property Dato1: Integer read Fid write setId default 0;
property Dato2: String read FPlaca write setPlaca;
property Dato3: String read FPuesto write setPuesto;
property Dato4: String read FCliente write setCliente;
Property Status: Boolean read FStatus write setStatus;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('JairoRamos', [TPuesto]);
end;
{ TBado }
constructor TPuesto.Create(AOwner: TComponent);
begin
inherited;
Fid:= 0;
FPlaca:= 'Placa del Vehiculo';
Fpuesto:= 'Numero del Puesto';
FCliente:= 'Cliente';
FStatus := false;
length(FPoints,4);
TabStop:= true;
end;
destructor TPuesto.Destroy;
begin
//inherited;
end;
procedure TPuesto.paint;
var
R : TrectR
begin
inherited paint;
R := GetShapeRect;
FPoints[0] := PointF(R.Left, R.Bottom);
FPoints[1] := PointF(R.Right, R.Bottom);
FPoints[2] := PointF(R.Right, R.Top);
FPoints[3] := PointF(R.Left, R.top);
FPoints[4] := PointF(R.Left, R.Bottom);
if FStatus then
canvas.Fill.Color:= ColorOcupado
else
canvas.Fill.Color:= ColorLibre;
Canvas.FillPolygon(FPoints, AbsoluteOpacity);
Canvas.Stroke.Kind:= tbrushkind.Solid;
canvas.Stroke.Thickness:= 1;
canvas.Stroke.Color:= talphacolors.Black;
Canvas.DrawPolygon(FPoints, AbsoluteOpacity);
end;
Pues esta es la maqueta de los que he dejado de tanto borrar y editar. el problema principal es que cuando pinto el fondo o re-dimensiono el componente solamente lo hace en tiempo de diseno ya que en ejecución no lo hacer. Se que es un componente sencillo pero realmente es primera vez que intento hacer algún componente en FMX y no doy pie con bolas, ya que la documentación al respecto es algo ambigua. realmente necesito de su ayuda aunque sea en su forma mas simple.