[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.
实现原理就是将背景窗口截个图，再模糊一下，显示在一个置顶的控件上，再显示模态窗口。
这个实现性能不怎么好，正式使用的不是这个实现。
