[Delphi] 分享一个模态弹窗背景模糊的实现

这是一个很久以前写的demo，今天又看到了，就发出来记录一下。

先来看一下效果图：

代码很简单

Unit1.pas

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    Edit1: TEdit;
    CheckBox1: TCheckBox;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

uses
  Unit2;

type
  TMCustomControl = class(TCustomControl);
  
const
  HSLRange: Integer = 240;

type
  TPixelLine = Array[Word] of TRGBQuad;
  pPixelLine = ^TPixelLine;

type
  PDIBInfo = ^TDIBInfo;
  TDIBInfo = object
    BufferDC: HDC;          // 兼容内存DC
    BufferBits: Pointer;    // 位图数据
    BytesPerRow: Integer;   // 每行数据的大小
    OldBitmap, BufferBitmap: HBitmap; // 位图句柄
    bmInfo: TBitmapInfo;    // 位图信息
    function InitDIB(dc: HDC; aw, ah: Integer): Boolean;
    function GetScanline(Row: Integer): PRGBQuad;
    procedure FreeRes();
  end;

procedure InitBmpInfo(var bInfo: TBitmapInfo; w, h: Integer; bitCount: Word = 32); inline;
begin
  FillChar(bInfo, SizeOf(bInfo), 0);
  with bInfo.bmiHeader do begin
    biSize := SizeOf(TBitmapInfoHeader);
    biWidth := w;
    biHeight := h;
    biPlanes := 1;
    biBitCount := bitCount;
    biCompression := BI_RGB;
    biSizeImage := w * h * (biBitCount div 8);
  end;
end;

{ TDIBInfo }

procedure TDIBInfo.FreeRes;
begin
  if BufferDC <> 0 then begin
    SelectObject(BufferDC, OldBitmap);
    DeleteObject(BufferBitmap);
    DeleteDC(BufferDC);
  end;
end;

function TDIBInfo.GetScanline(Row: Integer): PRGBQuad;
begin
  Integer(Result) := Integer(BufferBits) + Row * BytesPerRow;
end;

function TDIBInfo.InitDIB(dc: HDC; aw, ah: Integer): Boolean;
begin
  Result := False;
  BufferDC := 0;
  if (aw < 1) or (ah < 1) then Exit;
  // 创建内存兼容DC
  BufferDC := CreateCompatibleDC(dc);
  if (BufferDC = 0) then Exit;

  // 初始化临时DIB位图信息
  InitBmpInfo(bmInfo, aw, ah, 32);

  // 创建临时DIB位图
  BufferBitmap := CreateDIBSection(BufferDC, bmInfo, DIB_RGB_COLORS,
    BufferBits, 0, 0);
  if (BufferBitmap = 0) or (BufferBits = Nil) then begin
    if BufferBitmap <> 0 then DeleteObject(BufferBitmap);
    DeleteDC(BufferDC);
    BufferDC := 0;
    Exit;
  end;
  OldBitmap := SelectObject(BufferDC, BufferBitmap);

  // DIB数据行大小
  BytesPerRow := (((bmInfo.bmiHeader.biBitCount * aw) + 31)
    and not 31) div 8;
    
  Result := True;
end;


{-------------------------------------------------------------------------------
  函数名:    FillTransRect
  作者:      YangYxd
  日期:      2013.08.28
    - dc: HDC;                     目标设备场景句柄
    - r: TRect;                    目标矩形区域
    - color: LongInt;              阴影颜色
    - alpha: Byte;                 透明度（0..255）
    - blur: Byte;                  模糊半径 (半径越大，速度越慢）
  返回值:    无
-------------------------------------------------------------------------------}
function FillTransRect(dc: HDC; r: TRect; color: LongInt; alpha: Byte; blur: Byte): LongInt;
var
  DIBInfo      : TDIBInfo;
  BufferDC     : HDC;
  Bursh        : HBRUSH;

  ImageData,
  UpRowData,
  NextRowData  : pPixelLine;

  p1, p3, p5, p6, p8: PRGBQuad;
  cr, cg, cb   : Integer;
  nalpha       : Byte;
  
  i, j, x, y : Integer;
  W, H : Integer;
begin
  Bursh := CreateSolidBrush(color);
  if alpha < 1 then begin
    FillRect(dc, r, Bursh);
  end else begin
    w := r.Right - r.Left;
    h := r.Bottom - r.Top;
    if not DIBInfo.InitDIB(dc, w, h) then begin
      DIBInfo.FreeRes;
      Exit;
    end;
    BufferDC := DIBInfo.BufferDC;

    cr := color and MaxByte;;
    cg := (color shr 8) and MaxByte;;
    cb := (color shr 16) and MaxByte;
    nalpha := not alpha;
    BitBlt(BufferDC, 0, 0, w, h, DC, r.Left, r.Top, SRCCOPY);

    ImageData := DIBInfo.BufferBits;
    for y := 1 to H do begin
      for x := 0 to W - 1 do begin
        p1 := @ImageData^[x];
        p1.rgbBlue := ($7F + p1.rgbBlue * alpha +
          cb * (nalpha)) div $FF;
        p1.rgbGreen := ($7F + p1.rgbGreen * alpha +
          cg * (nalpha)) div $FF;
        p1.rgbRed := ($7F + p1.rgbRed * alpha +
          cr * (nalpha)) div $FF;
      end;
      inc(Longint(ImageData), DIBInfo.BytesPerRow);
    end;
    
    for i := 1 to blur - 1 do begin
      UpRowData := DIBInfo.BufferBits;
      ImageData := UpRowData;
      Inc(Longint(ImageData), DIBInfo.BytesPerRow);
      NextRowData := ImageData;
      Inc(Longint(NextRowData), DIBInfo.BytesPerRow);
      for y := 2 to H - 1 do begin
        for x := 1 to W - 3 do begin
          p1 := @ImageData^[x];
          p3 := @UpRowData^[x];
          p5 := @ImageData^[x-1];
          p6 := @ImageData^[x+1];
          p8 := @NextRowData^[x];

          p1.rgbBlue := (p1.rgbBlue + p3.rgbBlue + p5.rgbBlue + p6.rgbBlue + p8.rgbBlue) div 5;
          p1.rgbGreen := (p1.rgbGreen + p3.rgbGreen + p5.rgbGreen + p6.rgbGreen + p8.rgbGreen) div 5;
          p1.rgbRed := (p1.rgbRed + p3.rgbRed + p5.rgbRed + p6.rgbRed + p8.rgbRed) div 5;
        end;
        UpRowData := ImageData;
        ImageData := NextRowData;
        inc(Longint(NextRowData), DIBInfo.BytesPerRow);
      end;
    end;

    BitBlt(dc, r.Left, r.Top, w, h, BufferDC, 0, 0, SRCCOPY);  
    DIBInfo.FreeRes;
  end;
  DeleteObject(Bursh);
end;

function ShowModel(AOwner: TCustomForm; const FromCls: TFormClass): Integer;

  function CaptureScreen(const R: TRect): TBitmap;
  const
    CAPTUREBLT = $40000000;
  var
    hdcScreen: HDC;
    hdcCompatible: HDC;
    hbmScreen: HBITMAP;
  begin
    hdcScreen := GetDC(0);
    hdcCompatible := CreateCompatibleDC(hdcScreen);
    hbmScreen := CreateCompatibleBitmap(hdcScreen, GetDeviceCaps(hdcScreen, HORZRES), GetDeviceCaps(hdcScreen, VERTRES));
    if hbmScreen <> 0 then begin
      Result := TBitmap.Create;
      Result.Handle := hbmScreen;
      SelectObject(hdcCompatible, hbmScreen);
      BitBlt(hdcCompatible, 0, 0, Result.Width, Result.Height, hdcScreen, R.Left, R.Top, SRCCOPY or CAPTUREBLT);
    end;
    DeleteDC(hdcScreen);
    DeleteDC(hdcCompatible);
    // 画上半透明区域
    FillTransRect(Result.Canvas.Handle, Result.Canvas.ClipRect, clBlack, 110, 5);
  end;

  function CaptureWindow(const Wnd: THandle): TBitmap;
  var
    R: TRect;
    PT: TPoint;
  begin
    GetWindowRect(Wnd, R);
    SetRect(R, 0, 0, R.Right - R.Left, R.Bottom - R.Top);
    PT := R.TopLeft;
    ClientToScreen(AOwner.Handle, PT);
    R.TopLeft := PT;
    PT := R.BottomRight;
    ClientToScreen(AOwner.Handle, PT);
    R.BottomRight := PT;
    Result := CaptureScreen(R);
  end;

var
  P: TMCustomControl;
  V: Integer;
  Bmp: TBitmap;
  F: TCustomForm;
begin
  Bmp := CaptureWindow(AOwner.Handle);
  P := TMCustomControl.Create(AOwner);
  try
    P.Parent := AOwner;
    P.Left := 0;
    P.Top := 0;
    P.Width := AOwner.Width;
    P.Height := AOwner.Height;
    P.Enabled := False;
    P.Canvas.Draw(0, 0, Bmp);
    P.Visible := True;
    P.SetZOrder(True);
    FreeAndNil(Bmp);

    F := FromCls.Create(AOwner);
    Result := F.ShowModal;
  finally
    FreeAndNil(Bmp);
    AOwner.RemoveControl(P);
    P.Free; 
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  ShowModel(Self, TForm2);
end;

end.

Unit2.pas

unit Unit2;

interface

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

type
  TForm2 = class(TForm)
    procedure FormDblClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form2: TForm2;

implementation

{$R *.dfm}

procedure TForm2.FormDblClick(Sender: TObject);
begin
  Close;
end;

end.

实现原理就是将背景窗口截个图，再模糊一下，显示在一个置顶的控件上，再显示模态窗口。

这个实现性能不怎么好，正式使用的不是这个实现。