Форум: "Компоненты";
Текущий архив: 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.5 MB
Время: 0.04 c
