-
Может кому-то нужно, заодно и покритикуете.
procedure PrintParentFullZOrder(Control: TControl; DC: HDC);
var
LastOrigin: TPoint;
i: Integer;
ControlInd: Integer;
lControl: TControl;
lIntersectRect, FirstRect, SecondRect: TRect;
begin
if not Assigned(Control.Parent) then Exit;
if not (Control is TWinControl) then Exit;
GetWindowOrgEx(DC, LastOrigin);
SetWindowOrgEx(DC, LastOrigin.X + Control.Left, LastOrigin.Y + Control.Top, nil);
Control.Parent.Perform(WM_ERASEBKGND, Integer(DC), Integer(DC));
Control.Parent.Perform(WM_PRINT, DC, PRF_CLIENT or PRF_ERASEBKGND);
ControlInd := Control.Parent.ControlCount - 1;
for i := 0 to ControlInd do
begin
lControl := Control.Parent.Controls[i];
if lControl = Control Then Break;
if not (lControl is TWinControl) then Continue;
if not lControl.Visible then Continue;
FirstRect.Left := lControl.Left;
FirstRect.Top := lControl.Top;
FirstRect.Right := lControl.Left + lControl.Width;
FirstRect.Bottom := lControl.Top + lControl.Height;
SecondRect.Left := Control.Left;
SecondRect.Top := Control.Top;
SecondRect.Right := Control.Left + Control.Width;
SecondRect.Bottom := Control.Top + Control.Height;
if not IntersectRect(lIntersectRect, FirstRect, SecondRect) then Continue;
SetWindowOrgEx(DC, LastOrigin.X - lControl.Left + Control.Left, LastOrigin.Y - lControl.Top + Control.Top, nil);
lControl.Perform(WM_ERASEBKGND, Integer(DC), Integer(DC));
lControl.Perform(WM_PRINT, DC, PRF_CLIENT or PRF_ERASEBKGND or PRF_CHILDREN);
end;
SetWindowOrgEx(DC, LastOrigin.X, LastOrigin.Y, nil);
end; Для отсутствия мигания элемент на котором рисуется должен быть DoubleBuffered = True; Вызывать в Paint оконных элементов Основной баг(неустранимый) - если прозрачные элементы накладываются друг на друга, то отрисовка тормозит. (Количество перекрывающихся прозрачных элементов)!
-
А как её использовать?
-
> Kolan © (25.12.07 21:52) [1] > > А как её использовать?
В Paint наследника TCustomControl рисовать на свой Canvas.Handle procedure Paint;
begin
PrintParentFullZOrder(Self, Canvas.Handle);
end;
-
> В Paint наследника TCustomControl рисовать на свой Canvas.Handle
И что будет? Не понял что значит «функцию прозрачности»
может полупрозрачность
А как тогда задать величину(AlphaBlend)?
-
> Kolan © (25.12.07 22:01) [3] > > > В Paint наследника TCustomControl рисовать на свой Canvas. > Handle > > И что будет? Не понял что значит «функцию прозрачности»… > может полупрозрачность… А как тогда задать величину(AlphaBlend)?
Именно прозрачности.
Можно рисовать на Canvas TBitmap, получаешь полную копию экрана под твоим оконным компонентом. А дальше уже смешать два TBitmap(подложка и отрисовка) - стандартный способ.
-
procedure TForm1.PaintBox1Paint(Sender: TObject);
begin
PrintParentFullZOrder(Panel1, PaintBox1.Canvas.Handle);
end; И где чудо?
-
Мдааа... FirstRect.Left := lControl.Left;
FirstRect.Top := lControl.Top;
FirstRect.Right := lControl.Left + lControl.Width;
FirstRect.Bottom := lControl.Top + lControl.Height;
FirstRect := lControl.BoundsRect;
SecondRect.Left := Control.Left;
SecondRect.Top := Control.Top;
SecondRect.Right := Control.Left + Control.Width;
SecondRect.Bottom := Control.Top + Control.Height;
if not IntersectRect(lIntersectRect, FirstRect, SecondRect) then Continue; if not IntersectRect(lIntersectRect, FirstRect.BoundsRect, Control.BoundsRect) then Continue;
-
> homm © (25.12.07 22:07) [5] > > procedure TForm1.PaintBox1Paint(Sender: TObject); > begin > PrintParentFullZOrder(Panel1, PaintBox1.Canvas.Handle); > > end; > И где чудо?
Подходит только для Win-контролов
-
> [7] Черный Шаман (25.12.07 22:51) > Подходит только для Win-контролов
Panel1 — Win-контрол.
-
> [0] Черный Шаман (25.12.07 21:40) > lControl.Perform(WM_PRINT, DC, PRF_CLIENT or PRF_ERASEBKGND > or PRF_CHILDREN);
А еще уконтроллов бывает Неклинтская часть, слыхал?
-
-
> homm © (25.12.07 23:00) [9] > > > [0] Черный Шаман (25.12.07 21:40) > > lControl.Perform(WM_PRINT, DC, PRF_CLIENT or PRF_ERASEBKGND > > or PRF_CHILDREN); > > А еще уконтроллов бывает Неклинтская часть, слыхал?
Бывает, но она в данном случае не нужна.
-
> [11] Черный Шаман (25.12.07 23:10) > Бывает, но она в данном случае не нужна.
Как не нужна? Она такая же часть окна.
-
> [10] Черный Шаман (25.12.07 23:09)
А теперь сам приглядись к примеру, и скажи, почему его так колбасит во все стороны, когда над контролами надписи пролетают. Подсказка: см [12]
-
> homm © (25.12.07 23:19) [13] > > > [10] Черный Шаман (25.12.07 23:09) > > А теперь сам приглядись к примеру, и скажи, почему его так > колбасит во все стороны, когда над контролами надписи пролетают. > Подсказка: см [12]
Сорри вы правы.
procedure PrintParentFullZOrder(Control: TControl; DC: HDC);
var
LastOrigin: TPoint;
i: Integer;
ControlInd: Integer;
lControl: TControl;
lIntersectRect: TRect;
begin
if not Assigned(Control.Parent) then Exit;
if not (Control is TWinControl) then Exit;
GetWindowOrgEx(DC, LastOrigin);
SetWindowOrgEx(DC, LastOrigin.X + Control.Left, LastOrigin.Y + Control.Top, nil);
Control.Parent.Perform(WM_ERASEBKGND, Integer(DC), Integer(DC));
Control.Parent.Perform(WM_PRINT, DC, PRF_CLIENT or PRF_ERASEBKGND);
ControlInd := Control.Parent.ControlCount - 1;
for i := 0 to ControlInd do
begin
lControl := Control.Parent.Controls[i];
if lControl = Control Then Break;
if not (lControl is TWinControl) then Continue;
if not lControl.Visible then Continue;
if not IntersectRect(lIntersectRect, lControl.BoundsRect, Control.BoundsRect) then Continue;
SetWindowOrgEx(DC, LastOrigin.X - lControl.Left + Control.Left, LastOrigin.Y - lControl.Top + Control.Top, nil);
lControl.Perform(WM_ERASEBKGND, Integer(DC), Integer(DC));
lControl.Perform(WM_PRINT, DC, PRF_CLIENT or PRF_ERASEBKGND or PRF_CHILDREN or PRF_NONCLIENT);
end;
SetWindowOrgEx(DC, LastOrigin.X, LastOrigin.Y, nil);
end;
-
Вот еще так попробуй: procedure SetLeft(Control:TWinControl; NewLeft: Integer);
begin
SetWindowPos(Control.Handle, 0, NewLeft, Control.Top, 0, 0, SWP_NOSIZE or SWP_NOZORDER or SWP_NOCOPYBITS );
end;
procedure TMainForm.Timer1Timer(Sender: TObject);
begin
SetLeft(SkinVisualControl1, SkinVisualControl1.Left+2);
SetLeft(SkinVisualControl2, SkinVisualControl2.Left+3);
if SkinVisualControl1.Left > 400 then SetLeft(SkinVisualControl1, 2);
if SkinVisualControl2.Left > 400 then SetLeft(SkinVisualControl2, 2);
SkinVisualControl1.Refresh;
SkinVisualControl2.Refresh;
end; Зы. Бесит VCL-ная особенность инвалидейтить все налюбой чих. От этого стока фликов.
-
> homm © (25.12.07 23:36) [15]
С [14] вроде багов не заметил. Что не так?
-
> [16] Черный Шаман (25.12.07 23:42) > Что не так?
Колбасит-с
-
> homm © (25.12.07 23:48) [17] > > > [16] Черный Шаман (25.12.07 23:42) > > Что не так? > > Колбасит-с
Но пока это лучший способ из тех что я видел без полной переделки VCL. Подойдет при нечастом изменении подложки.
Кстати, DoubleBuffered у контролов стоит?
SkinVisualControl1.DoubleBuffered := True; SkinVisualControl2.DoubleBuffered := True;
-
Если комбинировать ее с этой(аналог отрисовки бекраунда в темах XP, но работает начиная с Win95)
procedure PrintParentBackground(Control: TControl; DC: HDC);
var
LastOrigin: TPoint;
begin
if not Assigned(Control.Parent) then Exit;
if not (Control is TWinControl) then Exit;
GetWindowOrgEx(DC, LastOrigin);
SetWindowOrgEx(DC, LastOrigin.X + Control.Left, LastOrigin.Y + Control.Top, nil);
Control.Parent.Perform(WM_ERASEBKGND, Integer(DC), Integer(DC));
Control.Parent.Perform(WM_PRINT, DC, PRF_CLIENT or PRF_ERASEBKGND);
SetWindowOrgEx(DC, LastOrigin.X, LastOrigin.Y, nil);
end;
То совсем жить можно.
|