Форум: "Компоненты";
Текущий архив: 2006.08.20;
Скачать: [xml.tar.bz2];

Вниз

Transparent Titres Panel   Найти похожие ветки 

← →
Tirion   (2006-01-18 16:22) [0]

Всем здрасте
В общем трабла...

Написал класс аля TSecretPanel только со свойством прозрачности. Проблема в том, что при смещении DrawText в условиях SetBkMode(HDC, Transparent) текст размазывается, образуя на канве просто жирное пятно.

Для наглядности выложил пакет на http://tirion.nxt.ru/TransPnl.zip (зависит от RXLib)

---

← →
Rouse_ ©   (2006-01-18 17:11) [1]

Переб выводом текста. сначала удаляй старый...

---

← →
Tirion   (2006-01-18 17:30) [2]

Не все так просто...
перерисовка производится путем смещения области печати

---

← →
Rouse_ ©   (2006-01-18 18:43) [3]

так не пойдет, заново перерисовывай в таком случае...

---

← →
Tirion   (2006-01-19 09:54) [4]

Ты скачивал пакет? Смотрел как сделано?

---

← →
Tirion   (2006-01-19 11:56) [5]

Вот упрощенный вариант процедуры, наглядно показывающий проблему.

procedure TForm1.Button1Click(Sender: TObject);
var R: TRect;
   i: integer;
begin
 for i:=100 downto 0 do
   begin
     sleep(10);

     {очистка канвы результатов не дала}
     //InValidateRect(form1.handle,NIL,True);

     R:=Rect(0,i,0,0);

     {если убрать прозрачность, то все ничтяк, но тогда пропадает необходимость вообще что-либо писать}
     setbkmode(Canvas.Handle, transparent);

     drawtext(form1.Canvas.Handle,"test",-1,R,DT_NOCLIP);
   end;
end;

---

← →
Rouse_ ©   (2006-01-19 12:38) [6]

Качал, сильно не вникал. Это вроде аналог:

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

// 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;

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;

---

← →
Rouse_ ©   (2006-01-19 12:38) [7]

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.

---

← →
Tirion   (2006-01-19 13:00) [8]

Вещь, конечно занятная, но ведь весь прикол в прозрачности... именно для этого все и писалось... Есть идеи как побороть размытие (см. процедуру выше)?

---

← →
antonn ©   (2006-01-21 07:42) [9]

Tirion   (19.01.06 13:00) [8]
нужно заново нарисовать все, что на ней было. типа repaint. стереть - нет такого понятия.

---

← →
Tirion   (2006-01-23 09:39) [10]

> нужно заново нарисовать все, что на ней было. типа repaint.
>  стереть - нет такого понятия.

каким образом?

---

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

Форум: "Компоненты";
Текущий архив: 2006.08.20;
Скачать: [xml.tar.bz2];

Наверх

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