Bueno:
Esta mas que una pregunta es un aporte, espero que roman no se enoje.
Hace unos dias pregunte como ejecutar un evento sabiendo su nombre, bueno lo pude solucionar y quiero comparti mi experencia.
Lo que hace es un icono en una apliacion MDI en el form principal y le asigo un evento del menu principal, haciendo asi nuestros accesos mas usados de la aplicaion
Lo primero que me presento era como hacer el icono en la pantalla, para eso quise hacerlo y me tome con la pagina de
http://www.i-griegavcl.com/down.asp de donde tome un compontente y lo retoque un poquito para , concretamente es el SelPanel 1.05
aca les dejo el codigo del componete que yo retoque:
Código Delphi
[-]
unit Acceso;
interface
uses
Windows, Messages, SysUtils, Classes, Controls, Graphics;
type
TAccesoDirecto = class(TCustomControl)
private
FPicture:TPicture;
FColors:array[0..5] of TColor;
FOnMouseEnter,
FOnMouseLeave:TNotifyEvent;
FBorder:Boolean;
FBorderWidth:Integer;
FOver:Boolean;
FPosXPicture:Word;
FPosYPicture:Word;
FText:TCaption;
FTextFont:TFont;
FPosXText:Word;
FPosYText:Word;
FAlignment,
FTextAlign: TAlignment;
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 SetPosYPicture(Value:Word);
procedure SetText(Value:TCaption);
procedure SetPosXText(Value:Word);
procedure SetPosYText(Value:Word);
procedure SetTextFont(Value:TFont);
procedure FontChanged(Sender: TObject);
procedure SetAlignment(Value: TAlignment);
procedure SetTextAlign(Value: TAlignment);
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;
public
constructor Create(AOwner:TComponent);override;
destructor Destroy;override;
property Colors[Index:Integer]:TColor read GetColors Write SetColors;
Procedure SetAllTexts(S:String);
published
property Alignment: TAlignment read FAlignment write SetAlignment default taLeftJustify;
property TextAlign: TAlignment read FTextAlign write SetTextAlign default taLeftJustify;
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 BorderColor:TColor Index 1 read GetColors Write SetColors default clBlack;
property FocusedColor:TColor Index 2 read GetColors Write SetColors default clBtnHighlight;
property FocusedBorderColor:TColor Index 3 read GetColors Write SetColors default clBlack;
property OverColor:TColor Index 4 read GetColors Write SetColors default clBtnShadow;
property OverBorderColor:TColor Index 5 read GetColors Write SetColors default clBlack;
property PosXPicture:Word read FPosXPicture Write SetPosXPicture default 10;
property PosYPicture:Word read FPosYPicture Write SetPosYPicture default 10;
property PosXText:Word read FPosXText Write SetPosXText default 50;
property PosYText:Word read FPosYText Write SetPosYText default 1;
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;
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 TAccesoDirecto.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 TAccesoDirecto.Create(AOwner:TComponent);
begin
inherited;
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;
FPicture:=TPicture.Create;
FTextFont:=TFont.Create;
FTextFont.OnChange:=FontChanged;
FPosXPicture:=10;
FPosYPicture:=10;
FPosXText:=50;
FPosYText:=1;
FText:='';
Font.Style:=[fsBold];
FAlignment:=taLeftJustify;
FTextAlign:=taLeftJustify;
end;
destructor TAccesoDirecto.Destroy;
begin
FTextFont.Free;
FPicture.Free;
inherited;
end;
procedure TAccesoDirecto.CMTextChanged(var Message: TMessage);
begin
inherited;
invalidate;
end;
procedure TAccesoDirecto.WMSetFocus(var Message: TWMSetFocus);
begin
inherited;
Invalidate;
end;
procedure TAccesoDirecto.WMKillFocus(var Message: TWMSetFocus);
begin
inherited;
Invalidate;
end;
procedure TAccesoDirecto.CMMouseEnter(var Message: TMessage);
begin
inherited;
if Assigned(FOnMouseEnter) then FOnMouseEnter(Self);
FOver:=True;
Invalidate;
end;
procedure TAccesoDirecto.CMMouseLeave(var Message: TMessage);
begin
inherited;
if Assigned(FOnMouseLeave) then FOnMouseLeave(Self);
FOver:=False;
Invalidate;
end;
procedure TAccesoDirecto.SetPicture(Value:TPicture);
begin
FPicture.Assign(Value);
repaint;
end;
procedure TAccesoDirecto.SetPosXPicture(Value:Word);
begin
if FPosXPicture<>Value then
if value>0 then
begin
FPosXPicture:=Value;
invalidate;
end;
end;
procedure TAccesoDirecto.SetPosYPicture(Value:Word);
begin
if FPosYPicture<>Value then
if (value>=0) then
begin
FPosYPicture:=Value;
invalidate;
end;
end;
procedure TAccesoDirecto.SetPosXText(Value:Word);
begin
if FPosXText<>Value then
if Value>0 then
begin
FPosXText:=Value;
invalidate;
end;
end;
procedure TAccesoDirecto.SetPosYText(Value:Word);
begin
if FPosYText<>Value then
if Value>=0 then
begin
FPosYText:=Value;
invalidate;
end;
end;
procedure TAccesoDirecto.SetText(Value: TCaption);
begin
if FText<>Value then
begin
FText:=Value;
invalidate;
end;
end;
procedure TAccesoDirecto.SetTextFont(Value:TFont);
begin
FTextFont.Assign(Value);
end;
procedure TAccesoDirecto.FontChanged(Sender: TObject);
begin
invalidate;
end;
procedure TAccesoDirecto.SetBorder(Value:Boolean);
begin
if FBorder<>Value then
begin
FBorder:=Value;
Invalidate;
end;
end;
procedure TAccesoDirecto.SetBorderWidth(Value:integer);
begin
if FBorderWidth<>Value then
begin
if Value>0 then
FBorderWidth:=Value;
Invalidate;
end;
end;
procedure TAccesoDirecto.SetColors(Index:Integer;Value:TColor);
begin
if FColors[Index]<>Value then
begin
FColors[Index]:=Value;
Invalidate;
end;
end;
Function TAccesoDirecto.GetColors(Index:Integer):TColor;
begin
Result:=FColors[Index];
end;
procedure TAccesoDirecto.Click;
begin
inherited;
SetFocus;
end;
procedure TAccesoDirecto.KeyPress(var Key: Char);
begin
if (Key=#13) or (Key=#32) then
Click;
Key:=#0;
end;
procedure TAccesoDirecto.SetAlignment(Value: TAlignment);
begin
if FAlignment<>Value then
begin
FAlignment:=Value;
Invalidate;
end;
end;
procedure TAccesoDirecto.SetTextAlign(Value: TAlignment);
begin
if FTextAlign<>Value then
begin
FTextAlign:=Value;
Invalidate;
end;
end;
procedure TAccesoDirecto.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,desph:Integer;
begin
despv:= 3;
Desph:=0;
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 Focused then
begin
Pen.Color :=FocusedBorderColor;
Brush.Color:=FocusedColor;
end;
if FOver then
begin
Pen.Color :=OverBorderColor;
Brush.Color:=OverColor;
end;
FillRect(ClientRect);
Brush.Style:=bsClear;
if Assigned(Picture.Graphic) then
begin
Picture.Graphic.Transparent:=true;
if PosYPicture>0 then
Draw(BorderWidth+PosXPicture,((Height-Picture.Graphic.Height) div 2)+PosYPicture,Picture.Graphic)
else
Draw(BorderWidth+PosXPicture,0,Picture.Graphic)
end;
if Border then Rectangle(X, Y, X + W, Y + H);
Flags:=AAlignment[_BiDiMode(Alignment,BiDiMode)] or DT_NOPREFIX or DT_END_ELLIPSIS;
R:=Rect(posxText+desph,despv,width-desph,height-despv);
Font:=self.Font;
Drawtext(handle,PChar(caption),-1,R,flags);
Flags:=DT_WORDBREAK or AAlignment[_BiDiMode(TextAlign,BiDiMode)] or DT_NOPREFIX;
if PosYText>0 then
R:=Rect(posxText+desph,TextHeight(Caption)+PosYText+despv,width-despv,height-despv)
else
R:=Rect(posxText+desph,Picture.Graphic.Height+despv,width-despv,height-despv);
Font:=self.TextFont;
DrawText(Handle, PChar(Text), -1, R, Flags);
end;
end;
procedure Register;
begin
RegisterComponents('Ejemplo', [TAccesoDirecto]);
end;
end.
Lo que no supe hacer es como hacerle el fondo transparente y qle la altura se ajuste al texto del icono , si alguien tiene la capcidad de hacerlo buenisimo y mas si lo publica.
///sigo en tro mensaje