Re[3]: Очистить Canvas(прозрачный фон)
От: akasoft Россия  
Дата: 03.12.04 17:29
Оценка:
Здравствуйте, <Аноним>, Вы писали:

А>Как с этим оборость?


Посмотри RxLib, там есть такая функция

procedure CopyParentImage(Control: TControl; Dest: TCanvas);


Теоретически для обеспечения прозрачности под заданным контролом она заставляет контейнер (Parent) отрисовать все элементы (контролы, графические контролы типа TImage), попадающие в Bounds контрола. А затем ты поверх рисуешь уже своё изображение. Можно ещё добавить тонирование, аналог прозрачности с заданным процентом.


procedure CopyParentImage(Control: TControl; Dest: TCanvas);
var
  I, Count, X, Y, SaveIndex: Integer;
  DC: HDC;
  R, SelfR, CtlR: TRect;
begin
  if (Control = nil) or (Control.Parent = nil) then Exit;
  Count := Control.Parent.ControlCount;
  DC := Dest.Handle;
  with Control.Parent do ControlState := ControlState + [csPaintCopy];
  try
    with Control do begin
      SelfR := Bounds(Left, Top, Width, Height);
      X := -Left; Y := -Top;
    end;
    { Copy parent control image }
    SaveIndex := SaveDC(DC);
    try
      SetViewportOrgEx(DC, X, Y, nil);
      IntersectClipRect(DC, 0, 0, Control.Parent.ClientWidth,
        Control.Parent.ClientHeight);
      with TParentControl(Control.Parent) do begin
        Perform(WM_ERASEBKGND, DC, 0);
        PaintWindow(DC);
      end;
    finally
      RestoreDC(DC, SaveIndex);
    end;
    { Copy images of graphic controls }
    for I := 0 to Count - 1 do begin
      if Control.Parent.Controls[I] = Control then Break
      else if (Control.Parent.Controls[I] <> nil) and
        (Control.Parent.Controls[I] is TGraphicControl) then
      begin
        with TGraphicControl(Control.Parent.Controls[I]) do begin
          CtlR := Bounds(Left, Top, Width, Height);
          if Bool(IntersectRect(R, SelfR, CtlR)) and Visible then begin
            ControlState := ControlState + [csPaintCopy];
            SaveIndex := SaveDC(DC);
            try
//              SaveIndex := SaveDC(DC);
              SetViewportOrgEx(DC, Left + X, Top + Y, nil);
              IntersectClipRect(DC, 0, 0, Width, Height);
              Perform(WM_PAINT, DC, 0);
            finally
              RestoreDC(DC, SaveIndex);
              ControlState := ControlState - [csPaintCopy];
            end;
          end;
        end;
      end;
    end;
  finally
    with Control.Parent do ControlState := ControlState - [csPaintCopy];
  end;
end;



Пример её использования можно увидеть в TRxSpeedButton. Я когда-то делал нечто подобное, приведу текст метода Paint:
procedure TAclButton.Paint;
var
  R: TRect;
  SrcX, SrcY, Size, DX, DY: Integer;
  AState: TButtonState;
begin
//  inherited;
  AState := FState;
  if not FMouseInControl and (AState = bsUp) then
    AState := bsInactive;

  R := Rect(0, 0, Width, Height);
  with Canvas do
  begin
    Brush.Color := Color;
    Brush.Style := bsSolid;
    FillRect(R);
  end;

  if FTransparent then
    CopyParentImage(Self, Canvas);
    
  if csDesigning in ComponentState then
  begin
    Frame3D(Canvas, R, clBtnHighlight, clBtnShadow, 1);
//    InflateRect(R, -1, -1);
  end;

  if not Assigned(FGlyph) then
    Exit;

    SrcX := 0;
    SrcY := 0;
    if FGlyph.Width > FGlyph.Height then
    begin
      SrcX := FGlyph.Height * Ord(AState);
      Size := FGlyph.Height;
    end
    else
    begin
      SrcY := FGlyph.Width * Ord(AState);
      Size := FGlyph.Width;
    end;
    DX := (WidthOf(R) - Size) div 2;
    DY := (HeightOf(R) - Size) div 2;

    StretchBitmapTransparent(Canvas, FGlyph, FGlyph.TransparentColor,
      R.Left + DX, R.Top + DY, Size, Size, SrcX, SrcY, Size, Size);

end;
... << RSDN@Home 1.1.4 beta 3 rev. 240 silent >>
 
Подождите ...
Wait...
Пока на собственное сообщение не было ответов, его можно удалить.