Delphi 2007: GlassFrame

[jbg]

Du musst den Button von Hand mit (dem langsamen) GDI+ Zeichnen, da du mit der GDI (ohne Plus) keinen Alphakanal hast, der für den Glass-Effekt unbedingt notwendig ist.

Ich habe vor ein paar Monaten mal etwas herumgespielt und dabei kam das heraus. Sieht zwar noch nicht 100%-tig richtig aus, aber definitiv besser.

Delphi-Quellcode:

uses
  Types, UxTheme, DwmApi;

type
  TExtendedButton = class(TButton)
  private
    FSheetOfGlassControl: Boolean;
  protected
    procedure WndProc(var Message: TMessage); override;
  published
    property SheetOfGlassControl: Boolean read FSheetOfGlassControl
write FSheetOfGlassControl;
  end;

procedure DrawBuffered(Control: TWinControl; var Message: TMessage;
  TransparentBorderSize: Integer);
var
  DC, MemDC: HDC;
  PS: TPaintStruct;
  PaintBuffer: HPAINTBUFFER;
  R: TRect;
begin
  DC := BeginPaint(Control.Handle, PS);
  try
    PaintBuffer := BeginBufferedPaint(DC, PS.rcPaint, BPBF_COMPOSITED, nil, MemDC);
    if PaintBuffer <> 0 then
    begin
      Control.Perform(WM_ERASEBKGND, MemDC, MemDC);
      Control.Perform(WM_PRINTCLIENT, MemDC, PRF_CLIENT);
      if TransparentBorderSize > 0 then
      begin
        GetWindowRect(Control.Handle, R);
        OffsetRect(R, -R.Left, -R.Top);
        BufferedPaintSetAlpha(PaintBuffer, @PS.rcPaint, 0);
        InflateRect(R, -TransparentBorderSize, -TransparentBorderSize);
        BufferedPaintMakeOpaque(PaintBuffer, @R);
      end
      else
        BufferedPaintMakeOpaque(PaintBuffer, @PS.rcPaint);
      EndBufferedPaint(PaintBuffer, True);
    end;
  finally
    EndPaint(Control.Handle, PS);
  end;
end;

{ TExtendedButton }

procedure TExtendedButton.WndProc(var Message: TMessage);
begin
  if (Message.Msg = WM_PAINT) and SheetOfGlassControl and
DwmCompositionEnabled then
    DrawBuffered(Self, Message, 1)
  else
    inherited WndProc(Message);
end;


{ TForm1 }

procedure TForm1.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
  if GlassFrame.Enabled and GlassFrame.SheetOfGlass then
  begin
    { Do not paint the background because this will cause every control to have
      a Self.Color border. }
    with TMessage(Message) do
      Result := DefWindowProc(Handle, Msg, WParam, LParam);
  end
  else
    inherited;
end;