delphi 透明控件小结

将一个FORM变成透明的实质性手段就是拦截CMEraseBkgnd消息。

unit Utransform; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls; type TForm1 = class(TForm)

private { Private declarations }

public { Public declarations }

PROCEDURE CMEraseBkgnd(var Message:TWMEraseBkgnd);Message WM_ERASEBKGND;

end;

var Form1: TForm1;

implementation

{$R *.DFM}

PROCEDURE Tform1.CMEraseBkgnd(var Message:TWMEraseBkgnd);

BEGIN

brush.style:=bsClear;

Inherited;

END;

end.

//////////////////////////////////////
procedure TForm1.FormCreate(Sender: TObject);
begin
  Form1.Brush.Style := bsClear;
  Form1.BorderStyle := bsNone
end;

procedure TForm1.BitBtn1Click(Sender: TObject);
begin
  Application.Terminate;
end;
/////////////////////////////////////////////
用透明的控件呗. 一般继承自TGraphicControl的
(就是那些没有handle属性, 不能有focus的控件, 如image)
都有Transparent属性. 对TWinControl类的控件, 要实现透明只要完成以下
四步基本上就成了.
1.在Create中设定ControlStyle :=
ControlStyle - [csOpaque];)
2. override 它的CreateParams方法, exstyle 里加上WS_EX_TRANSPARENT.
3. 修改它的parent的window style, 去掉WS_CLIPCHILDREN.

  inherited CreateParams(Params);
  with Params do
  begin
  { 完全重画 }
    Style := Style and not WS_CLIPCHILDREN;
    Style := Style and not WS_CLIPSIBLINGS;
  { 增加透明 }
    ExStyle := ExStyle or WS_EX_TRANSPARENT;
  end;

4. 截获WM_ERASEBKGND, 什么都不做直接返回1.(不搽除背景)
一般有上面3步能成. 有些控件比如TPanel, 在它的paint中用了fillrect, 所以要实现透明的话还要override 它的paint方法,自己画.
按钮透明需要进一步处理.
createparams里加上style := style or BS_OWNERDRAW;
然后在WM_DRAWITEM中自己画吧

unit TransButton;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls;

type
TTransButton = class(TButton)
private
  FTransparent : Boolean;
 
  procedure SetTransparent(Value: Boolean);
  procedure WMEraseBkgnd(var Msg: TMessage); message WM_ERASEBKGND;
protected
  procedure CreateParams(var Params: TCreateParams); override;
  procedure SetParent(AParent: TWinControl); override;
published
  property Transparent: Boolean read FTransparent write SetTransparent;
end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('CX Lib', [TTransButton]);
end;

procedure TTransButton.SetTransparent(Value: Boolean);
begin
  if ftransparent <> value then
  begin
    ftransparent := value;
    if value then
      controlstyle := controlstyle - [csOpaque]
    else
      controlstyle := controlstyle + [csOpaque];
    invalidate;
  end;
end;

procedure TTransButton.WMEraseBkgnd(var Msg: TMessage);
var
  br: HBRUSH;
begin
  if ftransparent then
    msg.result := 1
  else
    inherited;
end;

procedure TTransButton.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  params.exstyle := params.exstyle or WS_EX_TRANSPARENT;
end;

procedure TTransButton.SetParent(AParent: TWinControl);
begin
  inherited SetParent(AParent);
  if (aparent <> nil) and aparent.HandleAllocated
    and (GetWindowLong(aparent.Handle, GWL_STYLE) or WS_CLIPCHILDREN <> 0) then
    SetWindowLong(aparent.handle, GWL_STYLE, GetWindowLong(aparent.Handle, GWL_STYLE)
                                            and not WS_CLIPCHILDREN);
end;

end.
//////////////////////////////////////////////////////////////
透明的TPanel
type
  TPanelBorder = set of (pbInnerRaised, pbInnerSunk, pbOuterRaised, pbOuterSunk);
  TTrPanel = class(TCustomPanel)
  private
    FTransparentRate : Integer;     // 透明度
   
    FBkGnd : TBitmap;               // 背景buffer
   
    procedure SetTransparentRate(value: Integer);
   
    procedure WMEraseBkgnd(var Msg: TMessage); message WM_ERASEBKGND;
   
  protected
    procedure BuildBkgnd; virtual;         // 生成半透明的背景
    procedure SetParent(AParent : TWinControl); override;
    procedure CreateParams(var Params: TCreateParams); override;
    procedure Paint; override;
  public
    Constructor Create(AOwner: TComponent); override;
    Destructor Destroy; override;
    procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;  // resize or move
    procedure Invalidate; override;
    procedure InvalidateA; virtual;
  published
    property TransparentRate: Integer read FTransparentRate write SetTransparentRate;
    property ......
     ........          // 可以抄TPanel里面的
  end;

procedure Register;

implimentation
procedure Register;
begin
  RegisterComponent('Samples', [TTrPanel]);
end;

procedure TTrPanel.SetTransparentRate(value: Integer);
begin
  if (value <0) or (value > 100) then exit;
  if value <> FTransparentRate then
  begin
    FTransparentRate := value;
    Invalidate;
  end;
end;

procedure TTrPanel.WMEraseBkgnd(var Msg: TMessage);
begin
  Msg.Result := 1;
end;

procedure TTrPanel.SetParent(AParent: TWinControl);
begin
  inherited SetParent(AParent);
  if (AParent <> nil) and AParent.HandleAllocated
  and (GetWindowLong(AParent.Handle, GWL_STYLE) and WS_CLIPCHILDREN <> 0)
  then
    SetWindowLong(AParent.Handle, GWL_STYLE,
             GetWindowLong(AParent.Handle, GWL_STYLE)
             and not WS_CLIPCHILDREN);
end;

procedure TTrPanel.CreateParams(.....);
begin
  inherited CreateParams(Params);
  params.ExStyle := Params.ExStyle or WS_EX_TRANSPARENT;
end;

procedure TTrPanel.Paint;
begin
  if not assigned(FBkgnd) then
    BuildBkgnd;
  bitblt(Canvas.handle, 0, 0, width, height, FBkgnd.Canvas.Handle, 0, 0, SRCCOPY);
    ........
    ........    // 画边框, 画caption等, 就不写了.
end;
type
  T24Color = record
    b, g, r: Byte;
  end;
  P24Color := ^T24Color;

procedure TTrPanel.BuildBkgnd;
var
  p, p1: P24Color; 
  C : LongInt;
  i, j: Integer;
begin
  FBkgnd := TBitmap.Create;
  FBkgnd.PixelFormat := pf24Bit;
  FBkgnd.Width := Width;
  FBkgnd.Height := Height;
  if ftransparentrate > 0 then
  begin
    BitBlt(FBkgnd.Canvas.handle, 0, 0, Width, Height, Canvas.Handle, 0, 0, SRCCOPY);
    if ftransparentrate < 100 then   // 部分透明
    begin   
      c := ColorToRGB(Color);
                                        // 注意: ColorToRGB得到的颜色r, b位置与
                                        // scanline中颜色顺序正好相反.
      p1 := @c;
      for i := 0 to FBkgnd.Height - 1 do
      begin
        p := FBkgnd.Scanline[i];
        for j := 0 to FBkgnd.Width - 1 do
        begin
          p^.r := (p^.r * ftransparentrate + p1^.b * (100-ftransparentrate)) div 100;
          p^.g := (p^.g * ftransparentrate + p1^.g * (100-ftransparentrate)) div 100;
          p^.b := (p^.b * ftransparentrate + p1^.r * (100-ftransparentrate)) div 100;
          p := pointer(integer(p)+3);
        end;
      end;
    end;
  end
  else begin     // 不透明
    c := CreateSolidBrush(ColorToRGB(color));
    FillRect(fFBkgnd.canvas.handle, c);
    deleteobject(c);   
  end;
  controlstyle := controlstyle + [csOpaque];   // 背景没有变化时的重画不会出现闪烁
end;

Constructor TTrPanel.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  fbkgnd := nil;
  fTransparentRate := 0;
end;

Destructor TTrPanel.Destroy;
begin
  if assigned(fbkgnd) then
    fbkgnd.free;
  inherited;
end;

procedure TTrPanel.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
begin
  if ftransparentrate > 0 then    // 移动时能获得正确的背景
    invalidate;
  inherited;
end;

procedure TTrPanel.Invalidate;    // 刷新时重新计算背景
begin
  if assigned(fbkgnd) then
  begin
    fbkgnd.free;
    fbkgnd := nil;
    controlstyle := constrolstyle - [csOpaque];
  end;
  inherited;
end;

procedure TTrPanel.InvalidateA;  // 刷新时不重新计算背景(可以加快显示速度)
begin
  inherited Invalidate;
end;

end.
//////////////////////////////////////////////
unit homepage_coolform;interfaceuses
 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
 ExtCtrls, StdCtrls, Buttons;

type TForm1 = class(TForm)
  procedure FormPaint(Sender: TObject);
  procedure FormShow(Sender: TObject);
  procedure FormDestroy(Sender: TObject);
 private   { Private declarations }
 public  { Public declarations }
  hbmp:integer;
 end;

var Form1: TForm1;

implementation
{$R *.DFM}
function CopyScreenToBitmap(Rect:TREct):integer;
var
  hScrDC, hMemDC, hBitmap, hOldBitmap:integer;    
  nX, nY, nX2, nY2: integer;
  nWidth, nHeight:integer;     
  xScrn, yScrn:integer;
begin
 if (IsRectEmpty(Rect)) then
 begin
  result:= 0;
  exit;
 end; // 获得屏幕缓冲区的句柄.
 // a memory DC compatible to screen DC
 hScrDC:= CreateDC('DISPLAY', pchar(0), pchar(0), PDeviceModeA(0));
 hMemDC:= CreateCompatibleDC(hScrDC);
 // get points of rectangle to grab
 nX := rect.left;
 nY := rect.top;
 nX2 := rect.right;
 nY2 := rect.bottom;
 // get screen resolution
 xScrn:= GetDeviceCaps(hScrDC, HORZRES);
 yScrn := GetDeviceCaps(hScrDC, VERTRES);
 //make sure bitmap rectangle is visible
 if (nX <0) then
            nX :="0;"
      if (nY < 0) then
            nY :="0;"
      if (nX2> xScrn) then
  nX2 := xScrn;
 if (nY2 > yScrn) then
  nY2 := yScrn;
 nWidth := nX2 - nX;
 nHeight := nY2 - nY;
 // create a bitmap compatible with the screen DC
 hBitmap := CreateCompatibleBitmap(hScrDC, nWidth, nHeight);
 // select new bitmap into memory DC
 hOldBitmap := SelectObject(hMemDC, hBitmap);
 // bitblt screen DC to memory DC
 BitBlt(hMemDC, 0, 0, nWidth, nHeight, hScrDC, nX, nY, SRCCOPY);
 // select old bitmap back into memory DC and get handle to
 // bitmap of the screen
 hBitmap := SelectObject(hMemDC, hOldBitmap);
 // clean up
 DeleteDC(hScrDC);
 DeleteDC(hMemDC);
 result:= hBitmap;
end;

procedure TForm1.FormShow(Sender: TObject);
Var
 rect:TRect;
 p:TPoint;
begin
 rect:=ClientRect;
 p:=ClientOrigin;
 rect.left:=p.x;
 rect.top:=p.y;
 rect.bottom:=rect.bottom+p.y;
 rect.right:=rect.right+p.x;
 hbmp:=copyScreenToBitmap(rect);
 inherited;
end;

procedure TForm1.FormPaint(Sender: TObject);
var
 bitmap:TBitmap;
 rect:TRect;
begin
 bitmap:=TBitmap.create;
 bitmap.handle:=hbmp;
 rect:=ClientRect;
 canvas.draw(rect.left,rect.top,bitmap);
 bitmap.handle:=0;
 bitmap.free;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
 DeleteObject(hbmp);
end;

end.
////////////////////////////////////////////

type
  TBackgroundStyle = (bsOpaque, bsTransparent);

  TCustomButtonPanel = class(TScrollBox)
    private
      FCanvas: TCanvas;  { Need a Canvas }
    protected
      procedure WMSize(var Message: TWMSize); message WM_SIZE;
      procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
      procedure WMMove(var Message: TWMMove); message WM_MOVE;
      procedure CreateParams(var Params: TCreateParams); override;
      procedure PaintWindow(DC: HDC); override;
      procedure Paint; virtual;
      procedure InvalidateFrame;
      property BackgroundStyle:  TBackgroundStyle
            read FBackgroundStyle
            write SetBackgroundStyle
            default bsOpaque;
      ... other stuff snipped ...
    public
      constructor Create(AOwner: TComponent); override;
      property Canvas: TCanvas read FCanvas;
      ... other stuff snipped ...
  end;

... other code and stuff snipped ...

implementation

constructor TCustomButtonPanel.Create(AOwner: TComponent);
begin
  FBackgroundStyle := bsOpaque;
  inherited Create(AOwner);
  ControlStyle := [csAcceptsControls, csCaptureMouse, csClickEvents,
                   csSetCaption, csOpaque, csDoubleClicks];
  FCanvas := TControlCanvas.Create;
  TControlCanvas(FCanvas).Control := Self;
end;

procedure TCustomButtonPanel.SetBackgroundStyle(Value:TBackgroundStyle);
begin
  { BackgroundStyle Set Property Handler }
  if Value <> FBackgroundStyle then begin
    FBackgroundStyle := Value;
    RecreateWnd;
  end;
end;

procedure TCustomButtonPanel.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  with Params do begin
    if FBackgroundStyle = bsOpaque then
      ExStyle := ExStyle and not Ws_Ex_Transparent
    else
      ExStyle := ExStyle or Ws_Ex_Transparent;
  end;
end;

procedure TCustomButtonPanel.PaintWindow(DC: HDC);
begin
  { Setup the canvas and call the Paint routine }
  FCanvas.Handle := DC;
  try
    Paint;
  finally
    FCanvas.Handle := 0;
  end;
end;

procedure TCustomButtonPanel.Paint;
var
  theRect: TRect;
begin
  with canvas do
    brush.Color := Self.Color;
    theRect := GetClientRect;
    if FBackgroundStyle = bsOpaque then
      FillRect(theRect);
  ... other code and stuff snipped ...
  end;
end;

procedure TCustomButtonPanel.InvalidateFrame;
var
  R: TRect;
begin
  { Handle invalidation after move in designer }
  R := BoundsRect;
  InflateRect(R, 1, 1);
  InvalidateRect(Parent.Handle, @R, True);
end;

procedure TCustomButtonPanel.WMMove(var Message: TWMMove);
begin
  if (csDesigning in ComponentState) then
    InvalidateFrame;
  inherited;
end;

///////////////////////////////////////////////////
1. 使RichEdit的窗口透明. SetWindowLong(RichEdit.Handle, GWL_EXSTYLE, GetWindowLong(RichEdit.Handle,GWL_EXSTYLE) or WS_EX_TRANSPARENT);

2. 截获RichEdit的Wndproc, 处理以下消息:
    CN_CTLCOLORMSGBOX..CN_CTLCOLORSTATIC: 返回一个NullBrush的handle
(防止编辑状态时清除背景).
    WM_ERASEBKGND: 什么都不做就返回1(防止窗口在刷新时清除背景)

 

欢迎转载，但请保留出处，本文章转自[华软源码]，原文链接：http://www.hur.cn/special/Delphitech/02607.htm