Цель: получить прозрачный контрол(кнопку), который бы получал фокус, но на нем можно было рисовать что угодно.

Делаю наследника от TCustomControl. В CreateParam назначаю стиль WS_EX_TRANSPARENT:

TBlnOptionButton = class(TCustomControl)
 ...
protected
 procedure CreateParams(var Params: TCreateParams); override; 
 ...
end;

procedure TBlnOptionButton.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  with Params do
   begin
    ExStyle:=ExStyle+WS_EX_TRANSPARENT;
   end;
end;

далее отлавливаю сообщение WM_ERASEBKGROUND чтобы очистить фон.

procedure TBlnOptionButton.WMEraseBkgnd(var Msg: TWMEraseBkgnd);
begin
  Msg.Result := 1;           // Prevent background from getting erased
end;

Рисую на холсте, когда где что надо. Все ок, НО!!! Есить пара проблем

1. если я вывожу на Canvas прозрачную(не только по краям, но и в середине) картинку методом Draw, то при выводе надписи через API-функцию DrawText

DrawText(Canvas.Handle, CString, -1, TextBounds,
DT_LEFT or DT_WORDBREAK or DT_EXPANDTABS);

после нажатия щелчка на контрол остаются грязь. То есть при назатии на кнопку ее текст немного вдавливается(отрисовывается со смещение), и после этого грязь не убирается. Пробовал чистить Canvas через FillRect ниче не помогает.

2. При смене фокуса как честный програмер прорисовываю фокусную рамку обычными функциями LineTo с режимом пера pmNotXor:

 if Self.Focused then
  begin
   Canvas.Brush.Style:=bsClear;
   Canvas.Pen.Mode:=aPenMode;
   Canvas.Pen.Style:=psDot;
   Canvas.Pen.Color:=Self.Color;

   r:=Rect(TextLSpacing-3, TextTSpacing-3, Width-1, Height-1);

   Canvas.MoveTo(r.Left, r.Top);
   Canvas.LineTo(r.Right, r.Top);
   Canvas.LineTo(r.Right, r.Bottom);
   Canvas.LineTo(r.Left, r.Bottom);
   Canvas.LineTo(r.Left, r.Top);
  end

проблема в том что фокусная рамка убирается не при потере фокуса, а при получении следующего фокуса. То есть на четный раз рамка стирается, а на нечетный появляется. Что за ерунда?

Здравствуйте, Аноним, Вы писали:

Все правильно, нужно вызывать Invalidate, чтобы родитель перерисовал задний план, если ты хочешь можешь перед первой прорисовкой сохранить задний план родителя в битмап. А рамку лучше рисуй DrawFocusRect, естественно она пропадает после второго раза прорисовки на себя, она же использует инверсию, так что нужно рисовать один раз чтобы появилась и второй чтобы исчезла, но если ты будешь вызывать Invalidate второго раза не потребуется.

Здравствуйте, byterus, Вы писали:

B>Здравствуйте, Аноним, Вы писали:

B>Все правильно, нужно вызывать Invalidate, чтобы родитель перерисовал задний план,

Спасибо. Плучилось, но все равно не так. Я вызываю Invalidate родительсокго окна через Parent.Invalidate, происходит постоянное моргание когда я навожу мышку. Подбные контролы(к которым я стремлюсь) так не моргают.
Я понял, что прорисовывается все окно, поэтому вызываю API-функцию InvalidateRect в которую передается дискриптор окна и прямоугольник для очистки. И опять-таки все наполовину. Дейтсивтельно форму не мрогает, но зато когда назимаю на конопку, она сзчезает и появляется только когда я начинаю двигать мышью по кнопке.
Как с этим оборость?

B>А рамку лучше рисуй DrawFocusRect, естественно она пропадает после второго раза прорисовки на себя, она же использует инверсию, так что нужно рисовать один раз чтобы появилась и второй чтобы исчезла, но если ты будешь вызывать Invalidate второго раза не потребуется.

Приходиться использовать свою процедуру, так как мне нужно обрисовать не пунктиром, а точками необходимую область. А стандартный стиль Dot почему рисует коротким пунктиром. Но это ничего. Я так понял, что перерисова по нечетным разам была из-за того что не перерисовывался холст родительской формы.

Здравствуйте, <Аноним>, Вы писали:

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

Посмотри 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;

Спасибо всем! Усе прокатило!

Самое простой решение:
не исопьлзуй TCustomControl если не обязательно, а вместо него TGraphicControl !