Текущий архив: 2004.09.26;
Скачать: CL | DM;

Вниз

помогите, блин, кто может...   Найти похожие ветки 

← →
AdmeraL   (2004-09-06 17:33) [0]

как это в чатах(и не только) пишут бегущими строками...

---

← →
Prohodil Mimo ©   (2004-09-06 17:34) [1]

pishut ne strokami, a bukvami... a raz bukvi begut, znachit im tam ploho.

---

← →
Rouse_ ©   (2004-09-06 17:57) [2]

{*******************************************************}
{                                                       }
{       Borland Delphi Visual Component Library         }
{                                                       }
{     Copyright (c) 1998-2003 Fangorn Wizards Lab       }
{                                                       }
{ ----------------------------------------------------- }
{                                                       }
{ Author: Alexander (Rouse_) Bagel                      }
{ e-mail: rouse79@yandex.ru                             }
{ ICQ: 170677708                                        }
{                                                       }
{ Language of the author: Russian, English              }
{                                                       }
{*******************************************************}

// This component is FREEWARE with source code.
// All rights belong Fangorn Wizards Lab and me, as to a part of it.
// If you make any modifications to the code, please send them to me.
// If you have any ideas for improvement or bug reports, don"t hesitate to e-mail me.

unit FWInfoPanel;

interface

uses
 Windows, Messages, Controls, Classes, Graphics;

type
 TRGB = record
   B: Byte;
   G: Byte;
   R: Byte;
 end;
 PRGB = ^TRGB;

 TFWInfoPanel = class(TGraphicControl)
 private
   FActive: Boolean;
   FBitmap: TBitmap;
   FCharTimer: HWND;
   FCurrentChar: Integer;
   FCurrentLine: Integer;
   FCurrentString: String;
   FTextBitmap: TBitmap;
   FTextLeft: Integer;
   FScrollTimer: HWND;
   FStep: Byte;
   FStrings: TStringList;
   FWarning: String;
   FWnd: HWND;
   procedure SetStrings(Value: TStringList);
   procedure SetWarning(Value: String);
   procedure SetActive(Value: Boolean);
 protected
   procedure TmrProc(var Message: TMessage); virtual;
 public
   constructor Create(AOwner: TComponent); override;
   destructor Destroy; override;
   procedure Paint; override;
 published
   property Active: Boolean read FActive write SetActive default False;
   property Color default clAppWorkSpace;
   property Font;
   property Strings: TStringList read FStrings write SetStrings;
   property Warning: String read FWarning write SetWarning;
 end;

procedure Register;

implementation

procedure Register;
begin
 RegisterComponents("Fangorn Wizards Lab", [TFWInfoPanel]);
end;

{ TFWInfoPanel }

constructor TFWInfoPanel.Create(AOwner: TComponent);
begin
 inherited;
 Randomize;
 FBitmap := TBitmap.Create;
 FTextBitmap := TBitmap.Create;
 FTextBitmap.PixelFormat := pf24bit;
 FStrings := TStringList.Create;
 Color := clAppWorkSpace;
 FWnd := 0;
 FActive := False;
 FCharTimer := 0;
 FScrollTimer := 0;
 Height := 22;
 Width := 120;
 with Font do
 begin
   Style := [fsBold];
   Color := clWhite;
 end;
end;

destructor TFWInfoPanel.Destroy;
begin
 if FWnd <> 0 then
 begin
   KillTimer(FWnd, 1);
   KillTimer(FWnd, 2);
   Classes.DeallocateHWnd(FWnd);
 end;
 FBitmap.Free;
 FTextBitmap.Free;
 FStrings.Free;
 inherited;
end;

---

← →
Rouse_ ©   (2004-09-06 17:57) [3]

procedure TFWInfoPanel.Paint;

 function Block(const Value: Integer): Byte;
 begin
   Result := Value;
   if Value < 0 then Result := 0;
   if Value > 255 then Result := 255;
 end;
 
var
 Scan: PRGB;
 X, Y, D, Center: Integer;
 TmpCol: TColor;
 R, G, B: Byte;
begin
 inherited;
 
 with FTextBitmap do
 begin
   Width := Self.Width - 2;
   Height := Self.Height - 2;
   Canvas.Brush.Color := Self.Color;
   Canvas.Font.Assign(Self.Font);
   if FWarning <> "" then
   begin
     Canvas.Brush.Color := clBlack;
     Canvas.Font.Color := clRed;
   end;
   Canvas.FillRect(GetClientRect);
   if Canvas.TextWidth(FCurrentString) > (Width  - 2) then FStep := 1;
   if (FTextLeft) >= Canvas.TextWidth(FCurrentString) + 30  then
   begin
     FStep := 0;
     FTextLeft := 0;
     FCurrentChar := 0;
     FCurrentString := "";
     FCurrentLine := Random(FStrings.Count - 1);
     FWarning := "";
   end;
   Center := (Height - Canvas.TextHeight(FCurrentString)) div 2;
   Canvas.TextOut(10 - FTextLeft , Center, FCurrentString);

   TmpCol := ColorToRGB(Self.Color);
   if FWarning <> "" then TmpCol := clBlack;
   R := Byte(TmpCol);
   G := Byte(TmpCol shr 8);
   B := Byte(TmpCol shr 16);
   for Y := 0 to Height - 1 do
   begin
     Scan := FTextBitmap.ScanLine[Y];
     D:= 20;
     for X := 0 to D do
     begin
       if FStep = 1 then
       begin
         if X < 4 then
         begin
           Scan.R  := R;
           Scan.G  := G;
           Scan.B  := B;
         end
         else
         begin
           Scan.R  := Block(((Scan.R * X) + (R * (D - X))) div D);
           Scan.G  := Block(((Scan.G * X) + (G * (D - X))) div D);
           Scan.B  := Block(((Scan.B * X) + (B * (D - X))) div D);
        end;
       end;
       Inc(Scan);
     end;
     Inc(Scan, Width - (D + 2));
     for X := 0 to D do
     begin
       if X < 4 then
       begin
         Scan.R  := R;
         Scan.G  := G;
         Scan.B  := B;
       end
       else
       begin
         Scan.R  := Block(((Scan.R * X) + (R * (D - X))) div D);
         Scan.G  := Block(((Scan.G * X) + (G * (D - X))) div D);
         Scan.B  := Block(((Scan.B * X) + (B * (D - X))) div D);
       end;
       Dec(Scan);
     end;
   end;
 end;

 with FBitmap do
 begin
   Width := Self.Width;
   Height := Self.Height;
   DrawFrameControl(Canvas.Handle, GetClientRect, DFC_BUTTON, DFCS_BUTTONPUSH or DFCS_PUSHED);
 end;

 BitBlt(FBitmap.Canvas.Handle, 1, 1, Width - 1, Height - 1, FTextBitmap.Canvas.Handle, 0, 0, SRCCOPY);
 BitBlt(Canvas.Handle, 0, 0, Width, Height, FBitmap.Canvas.Handle, 0, 0, SRCCOPY);
end;

procedure TFWInfoPanel.SetActive(Value: Boolean);
begin
 if Value <> FActive then FActive := Value;
 if (csDesigning in ComponentState) then Exit;
 if Value then
 begin
   if FWnd = 0 then
   begin
     FWnd := Classes.AllocateHWnd(TmrProc);
     FCharTimer := SetTimer(FWnd, 1, 100, nil);
     FScrollTimer := SetTimer(FWnd, 2, 50, nil);
   end;
 end
 else
 begin
   if FWnd <> 0 then
   begin
     KillTimer(FWnd, 1);
     KillTimer(FWnd, 2);
     Classes.DeallocateHWnd(FWnd);
     FCharTimer := 0;
     FScrollTimer := 0;
     FWnd := 0;
     FCurrentString := "";
     FCurrentChar := 0;
     FStep := 0;
     FTextLeft := 0;
     Paint;
   end;
 end;
end;

procedure TFWInfoPanel.SetStrings(Value: TStringList);
begin
 FStrings.Assign(Value);
 FCurrentLine := Random(FStrings.Count - 1);
end;

procedure TFWInfoPanel.SetWarning(Value: String);
begin
 FStep := 0;
 FTextLeft := 0;
 FCurrentChar := 0;
 FCurrentString := "";
 FWarning := Value;
end;

procedure TFWInfoPanel.TmrProc(var Message: TMessage);
var
 TmpString: String;
begin
 if Message.Msg <> WM_TIMER then
 begin
   with Message do
     Result := DefWindowProc(FWnd, Msg, WParam, LParam);
   Exit;
 end;
 case Message.WParam of
   1:
   begin
     if FStrings.Count = 0 then
       TmpString := ""
     else
       TmpString := FStrings.Strings[FCurrentLine];
     if FWarning <> "" then TmpString := FWarning;
     if FCurrentChar < Length(TmpString) then
     begin
       Inc(FCurrentChar);
       FCurrentString := FCurrentString + TmpString[FCurrentChar];
     end
     else
       FStep := 1;
   end;
   2: Inc(FTextLeft, FStep);
 end;
 Paint;
end;

end.

---

← →
Гарри Поттер ©   (2004-09-06 18:23) [4]

Ты наверное это имел ввиду:

<MARQUEE BEHAVIOR=ALTERNATE DIRECTION="right">Здесь ваш текст</MARQUEE>

---

← →
icebeerg   (2004-09-06 18:24) [5]

<marquee>Бегущие буквы</marquee>

---

Страницы: 1 вся ветка

Текущий архив: 2004.09.26;
Скачать: CL | DM;

Наверх

Память: 0.49 MB
Время: 0.063 c