| Форумы
ЧАТ |
Орешник |
|
| Форумы -» | Основная («Начинающим»)/ Базы / WinAPI / Компоненты / Сети / Media / Игры / Corba и COM / KOL / FreePascal / .Net / Прочее / RSDN.ORG |
|
| ||
|
|
Новости |
Поиск |
FAQ |
Статьи |
Книги |
Новости VCL
| | Форумы ЧАТ |
Орешник |
|
| |||
| |||
| |||
« предыдущая ветвь | форум | следующая ветвь »
Transparent Titres Panel [D7, Win2k, WinXP]
Tirion © (2006-01-18 16:22:00)Всем здрасте
В общем трабла...
Написал класс аля TSecretPanel только со свойством прозрачности. Проблема в том, что при смещении DrawText в условиях SetBkMode(HDC, Transparent) текст размазывается, образуя на канве просто жирное пятно.
Для наглядности выложил пакет на http://tirion.nxt.ru/TransPnl.zip(зависит от RXLib)
Tirion (2006-01-23 09:39:00) [1]
> нужно заново нарисовать все, что на ней было. типа repaint.
> стереть - нет такого понятия.
каким образом?
antonn (2006-01-21 07:42:00) [2]Tirion (19.01.06 13:00) [8]
нужно заново нарисовать все, что на ней было. типа repaint. стереть - нет такого понятия.
Tirion (2006-01-19 13:00:00) [3]Вещь, конечно занятная, но ведь весь прикол в прозрачности... именно для этого все и писалось... Есть идеи как побороть размытие (см. процедуру выше)?
Rouse_ (2006-01-19 12:38:00) [4]Качал, сильно не вникал. Это вроде аналог:
{*******************************************************}
{ }
{ 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:00) [5]
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 11:56:00) [6]Вот упрощенный вариант процедуры, наглядно показывающий проблему.
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;
Tirion (2006-01-19 09:54:00) [7]Ты скачивал пакет? Смотрел как сделано?
Rouse_ (2006-01-18 18:43:00) [8]так не пойдет, заново перерисовывай в таком случае...
Tirion (2006-01-18 17:30:00) [9]Не все так просто...
перерисовка производится путем смещения области печати
Rouse_ (2006-01-18 17:11:00) [10]Переб выводом текста. сначала удаляй старый...
| |
