Club Delphi  
    FTP   CCD     Buscar   Trucos   Trabajo   Foros

Retroceder   Foros Club Delphi > Principal > OOP
Registrarse FAQ Miembros Calendario Guía de estilo Buscar Temas de Hoy Marcar Foros Como Leídos

Grupo de Teaming del ClubDelphi

 
 
Herramientas Buscar en Tema Desplegado
  #1  
Antiguo 02-07-2012
Chaja Chaja is offline
No confirmado
 
Registrado: ago 2004
Ubicación: Mar del Plata
Posts: 238
Poder: 0
Chaja Va por buen camino
Generar accesos Directos

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);
    { 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;
    { 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 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;
    { 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 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;
    //Height:=FPicture.Height
    invalidate;
//    Paint;
  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;
   //despv:= PosYText;

   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)

// original   Draw(BorderWidth+PosXPicture,((Height-Picture.Graphic.Height) div 2),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);

//      R:=Rect(posxText+desph,TextHeight(Caption)+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

Última edición por Casimiro Notevi fecha: 02-07-2012 a las 10:03:17.
Responder Con Cita
 


Herramientas Buscar en Tema
Buscar en Tema:

Búsqueda Avanzada
Desplegado

Normas de Publicación
no Puedes crear nuevos temas
no Puedes responder a temas
no Puedes adjuntar archivos
no Puedes editar tus mensajes

El código vB está habilitado
Las caritas están habilitado
Código [IMG] está habilitado
Código HTML está deshabilitado
Saltar a Foro

Temas Similares
Tema Autor Foro Respuestas Último mensaje
Crear accesos directos a un menú cmfab Varios 16 29-10-2012 18:07:20
¿Cómo ejecutar accesos directos? saulcell API de Windows 9 05-11-2010 08:40:36
Diferenciar accesos directos. rauros API de Windows 7 29-09-2008 23:20:08
extraer informacion de accesos directos lnk octalh API de Windows 2 22-03-2008 22:12:22
Creacion de Accesos directos con otros Iconos tango01 Varios 13 13-07-2004 19:21:04


La franja horaria es GMT +2. Ahora son las 02:55:44.


Powered by vBulletin® Version 3.6.8
Copyright ©2000 - 2024, Jelsoft Enterprises Ltd.
Traducción al castellano por el equipo de moderadores del Club Delphi
Copyright 1996-2007 Club Delphi