Mostrar mensajes con movibilidad

[[nlsgarcia]]

pape19,

Empezado por pape19

...mostrar en la pantalla principal de mi aplicación un mensaje que vaya corriendo...como los que muestran generalmente los noticieros de TV en la parte inferior...

Revisa este código:

Código Delphi [-]
unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Edit1: TEdit;
    Button1: TButton;
    Button2: TButton;
    Timer1: TTimer;
    Button3: TButton;
    procedure FormCreate(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;
  Msg, MsgRev, AuxMsg : String;
  PixelsFont, p, Pausa : Integer;

implementation

{$R *.dfm}

function CalculatePixels(F : TFont) : LongWord;
var
   C : TBitmap;
begin
   C := TBitmap.Create;
   C.Canvas.Font.Name := F.Name;
   C.Canvas.Font.Size := F.Size;
   Result := C.Canvas.TextWidth(' ');
   C.Free;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
   Edit1.ReadOnly := True;
   Timer1.Enabled := False;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin

   AuxMsg := Edit1.Text;

   if p <= Length(MsgRev) then
      Insert(MsgRev[p],AuxMsg,0)
   else
      Insert(' ',AuxMsg,0);

   Edit1.Text := AuxMsg;

   Inc(p);

   if p = Edit1.Width Div PixelsFont + 1 then
      p := 1;

end;

procedure TForm1.Button1Click(Sender: TObject);
begin

   if Timer1.Enabled then
      Exit;

   Edit1.Font.Name := 'Lucida Console'; // Solo TrueType fonts de tipo Monospaced
   Edit1.Font.Color := clBlue;
   Edit1.Font.Size := 12;

   PixelsFont := CalculatePixels(Edit1.Font);

   Msg := 'Nelson Garcia';
   MsgRev := ReverseString(Msg);

   if Pausa = 0 then
      p := 1
   else
   begin
      p := Pausa;
      Pausa := 0;
   end;

   Timer1.Interval := 150;
   Timer1.Enabled := True;

end;

procedure TForm1.Button2Click(Sender: TObject);
begin
   Timer1.Enabled := False;
   Pausa := p;
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
   Timer1.Enabled := False;
   Pausa := 0;
   Edit1.Text := EmptyStr;
end;

end.

El código anterior en Delphi 7 sobre Windows 7 Professional x32, implementa un generador de carácteres simple, como se muestra en la siguiente imagen:



Notas:

1- El generador esta basado en TrueType fonts de tipo Monospaced como Lucida Console, Courier New y Lucida Sans Typewriter, si se usan fonts de tipo proporcional el generador funcionara de forma aleatoria.

2- La idea de usar un tipo de letra mono espaciada, es lograr un efecto más fluido en el movimiento de los carácteres.

Espero sea útil

Nelson.

[ecfisa]

Hola pape19.

Quedé pensando en que se podría hacer una unidad que se encarge de gestionar el comportamiento para controles que tengan la propiedad Text o Caption, algo así:

Código Delphi [-]
unit uMarquee;

interface

uses Controls, ExtCtrls, TypInfo, Windows, Graphics, Dialogs, SysUtils;

type
  TSentido = (rtRight, rtLeft);
  TMarquee = class(TObject)
  private
    FControl  : TControl;
    FText     : string;
    FTimer    : TTimer;
    FSentido  : TSentido;
    procedure FTimerTime(Sender: TObject);
    procedure SetActive(const Value: Boolean);
    procedure SetInterval(const Value: Cardinal);
    procedure SetControl(const Value: TControl);
  public
    constructor Create(AOwner: TControl);
    destructor Destroy; override;
    property Component: TControl read FControl write SetControl;
    property Sentido  : TSentido read FSentido write FSentido;
    property Interval : Cardinal write SetInterval;
    property Active   : Boolean write SetActive;
  end;

implementation

constructor TMarquee.Create(AOwner: TControl);
begin
  FTimer         := TTimer.Create(nil);
  FTimer.Enabled := False;
  FTimer.OnTimer := FTimerTime;
  FSentido       := rtRight;
end;

destructor TMarquee.Destroy;
begin
  FTimer.Free;
  inherited;
end;

procedure TMarquee.FTimerTime(Sender: TObject);
begin
  if FSentido = rtRight then
    FText := Copy(FText, Length(FText), 1) + Copy(FText, 1, Length(FText) -1)
  else
    FText := Copy(FText, 2, Length(FText)-1) + Copy(FText,1, 1);

  if Assigned(GetPropInfo(FControl, 'Text')) then
    SetStrProp(FControl, GetPropInfo(FControl, 'Text'), FText);

  if Assigned(GetPropInfo(FControl, 'Caption')) then
    SetStrProp(FControl, GetPropInfo(FControl, 'Caption'), FText);
end;

procedure TMarquee.SetActive(const Value: Boolean);
begin
  if Value <> FTimer.Enabled then
    FTimer.Enabled := Value;
end;

procedure TMarquee.SetControl(const Value: TControl);
var
  l : Integer;
  F : TFont;
begin
  if FControl <> Value then
    FControl := Value;

  if IsPublishedProp(FControl, 'Text') then
    FText := GetStrProp(FControl, 'Text');
  if IsPublishedProp(FControl, 'Caption') then
     FText := GetStrProp(FControl, 'Caption');

  if IsPublishedProp(FControl, 'Font') then
  begin
    F := TFont(GetObjectProp(FControl, 'Font', TFont));
    l := (FControl.Width - Length(FText) * F.Size) div 2;
    FText :=FText + StringOfChar(' ', l);
  end;
end;

procedure TMarquee.SetInterval(const Value: Cardinal);
begin
  if Value <> FTimer.Interval then
    FTimer.Interval := Value;
end;

end.

Ejemplo de uso:

Código Delphi [-]
implementation 

uses uMarquee;

var
  m1,m2, m3, m4 : TMarquee;

procedure TForm1.FormCreate(Sender: TObject);
var
  s: string;
begin
  s := 'Prueba de desplazamiento de texto';
  Label1.Caption := s;
  Edit1.Text     := s;
  ComboBox1.Text := s;
  Form1.Caption  := s;

  m1 := TMarquee.Create(nil);
  m1.Component := Label1;
  m1.Interval  := 50;

  m2 := TMarquee.Create(nil);
  m2.Component := Edit1;
  m2.Interval  := 50;
  m2.Sentido   := rtLeft; // rtRight por defecto

  m3 := TMarquee.Create(nil);
  m3.Component := ComboBox1;
  m3.Interval  := 70;

  m4 := TMarquee.Create(nil);
  m4.Component := Form1;
  m4.Interval  := 80;
  m4.Sentido   := rtLeft;
end;

procedure TForm1.CheckBox1Click(Sender: TObject);
begin
  m1.Active := CheckBox1.Checked;
  m2.Active := CheckBox1.Checked;
  m3.Active := CheckBox1.Checked;
  m4.Active := CheckBox1.Checked;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  m1.Free;
  m2.Free;
  m3.Free;
  m4.Free;
end;

Salida:


Saludos

[[AgustinOrtu]]

Como ultima pregunta, en que version de Delphi? En Firemonkey podes usar las clases TAnimation

Por ejemplo, teniendo un Label1: TLabel en el form, se suelta un componente TFloatAnimation. Configuramos un par de propiedades (puede ser en diseño o en ejecucion)

Código Delphi [-]
  FloatAnimation1.AnimationType := TAnimationType.InOut;
  FloatAnimation1.PropertyName := Position.X;
  FloatAnimation1.Interpolation := 
  FloatAnimation1.Loop := True;

  // estos dos valores los halle "jugando"
  FloatAnimation1.StartValue := Label1.Text.Length * -6.5;
  FloatAnimation1.StopValue := Width + 30;
  FloatAnimation1.Start;
  FloatAnimation1.Stop;

[pape19]

He probado sus soluciones y todas funcionan bárbaro!

Particularmente me he quedado con la unit "uMarquee" publicada en el ultimo mensaje de ecfisa.

Son unos genios, han resuelto mi problema. Muchas gracias por la ayuda.