摘要：双缓冲绘图技术在Delphi中的实现
关键字：Delphi,双缓冲,Canvas
作者：上海翰博数码科技实业有限公司 沈小云
说明：假设读者熟悉VCL
双缓冲绘图也不是什么新技术，简单的说：在绘图实现时不直接绘在窗口上，而是先绘在内存里，再一起“拷贝”至窗口。实现起来也不复杂，创建一兼容HDC,在此兼容HDC上绘图，最后拷贝到窗口HDC就行了。本人前段时间把一C++实现该技术的代码改成了Delphi代码，都是用Win32API写的。今改成了使用Delphi自带的类，试了一下(窗口类Canvas与TImage的Canvas)。实现方式大同小异，但不得不提的是在窗口中直接使用Canvas绘图与TImage.Canvas却不相同。使用TImage.Canvas绘图时，自动使用了双缓冲技术，而窗口的Canvas对像却未实现。怎么回事呢？看一下代码吧，“源码面前没有秘密”!
一．TImage类的Canvas
TImage = class(TGraphicControl)
...
property Canvas: TCanvas read GetCanvas;
...
function TImage.GetCanvas: TCanvas;
var
Bitmap: TBitmap;
begin
if Picture.Graphic = nil then
begin
Bitmap := TBitmap.Create;
try
Bitmap.Width := Width;
Bitmap.Height := Height;
Picture.Graphic := Bitmap;
finally
Bitmap.Free;
end;
end;
if Picture.Graphic is TBitmap then
Result := TBitmap(Picture.Graphic).Canvas
else
raise EInvalidOperation.Create(SImageCanvasNeedsBitmap);
end;
可知TImage.Canvas来自Bitmap.Canvas，好，那来看看TBitmap.Canvas
function TBitmap.GetCanvas: TCanvas;
begin
if FCanvas = nil then
begin
HandleNeeded;
if FCanvas = nil then // possible recursion
begin
FCanvas := TBitmapCanvas.Create(Self);
FCanvas.OnChange := Changed;
FCanvas.OnChanging := Changing;
end;
end;
Result := FCanvas;
end;
显而易见TBitmap.Canvas = TBitmapCanvas.Create;也就是说TImage.Canvas=TBitmapCanvas.Create.即使用TImage.Canvas绘图时，实际是在TBitmapCanvas上绘图的。让我们再来看看TBitmapCanvas类:
TBitmapCanvas = class(TCanvas)
private
FBitmap: TBitmap;
FOldBitmap: HBITMAP;
FOldPalette: HPALETTE;
procedure FreeContext;
protected
procedure CreateHandle; override;
public
constructor Create(ABitmap: TBitmap);
destructor Destroy; override;
end;
关注一下CreateHandle函数:
procedure TBitmapCanvas.CreateHandle;
var
H: HBITMAP;
begin
if FBitmap <> nil then
begin
Lock;
try
FBitmap.HandleNeeded;
DeselectBitmap(FBitmap.FImage.FHandle);
//!! DeselectBitmap(FBitmap.FImage.FMaskHandle);
FBitmap.PaletteNeeded;
H := CreateCompatibleDC(0);
if FBitmap.FImage.FHandle <> 0 then
FOldBitmap := SelectObject(H, FBitmap.FImage.FHandle) else
FOldBitmap := 0;
if FBitmap.FImage.FPalette <> 0 then
begin
FOldPalette := SelectPalette(H, FBitmap.FImage.FPalette, True);
RealizePalette(H);
end
else
FOldPalette := 0;
Handle := H;
BitmapCanvasList.Add(Self);
finally
Unlock;
end;
end;
end;
读起来也不困难，FBitmap是Create构造函数传进来的。而我们应该关注的代码位于斜体部份，也很好理解：创建兼容DC，并选进设备。要的就是这个效果，现在知道为什么使用TImage.Canvas来绘图是使用的双缓冲技术的了吧？那么这个兼容DC是如何从内存“拷贝”到窗口的呢？
我们使用上面的分析方法，当TImage基类TGraphicControl收到WM_PAINT消息时，将执行下面的代码:
procedure TGraphicControl.WMPaint(var Message: TWMPaint);
begin
if Message.DC <> 0 then
begin
Canvas.Lock;
try
Canvas.Handle := Message.DC;
try
Paint;
finally
Canvas.Handle := 0;
end;
finally
Canvas.Unlock;
end;
end;
end;
(在此先仅关注Paint函数)
而TImage覆盖了此Paint虚函数:
procedure TImage.Paint;
var
Save: Boolean;
begin
if csDesigning in ComponentState then
with inherited Canvas do
begin
Pen.Style := psDash;
Brush.Style := bsClear;
Rectangle(0, 0, Width, Height);
end;
Save := FDrawing;
FDrawing := True;
try
with inherited Canvas do//祖先的Canvas
StretchDraw(DestRect, Picture.Graphic);
finally
FDrawing := Save;
end;
end;
抛开枝节，关注两个地方，一是斜体部份的Canvas对像，二是StrectchDraw函数。先看看此Canvas对像，它被显示声明为基类的Canvas对像。不得不提，此Canvas.Handle即句柄的赋值代码：
procedure TGraphicControl.WMPaint(var Message: TWMPaint);
begin
if Message.DC <> 0 then
begin
Canvas.Lock;
try
Canvas.Handle := Message.DC;
try
Paint;
finally
Canvas.Handle := 0;
end;
finally
Canvas.Unlock;
end;
end;
end;
是消息传递进来的，这里的DC为此TGraphicControl.Parent的DC。至于如何传递进来的请参考《VCL构架剖析》，在此不费话了。
再看第二个关注点StrectDraw函数:
procedure TCanvas.StretchDraw(const Rect: TRect; Graphic: TGraphic);
begin
if Graphic <> nil then
begin
Changing;
RequiredState(csAllValid);
Graphic.Draw(Self, Rect);
Changed;
end;
end;
这里的Graphic是什么呢？这里是TBitmap!看看第一块代码。那再看TBitmap.Draw函数吧：
procedure TBitmap.Draw(ACan
vas: TCanvas; const Rect: TRect);
var
OldPalette: HPalette;
RestorePalette: Boolean;
DoHalftone: Boolean;
Pt: TPoint;
BPP: Integer;
MaskDC: HDC;
Save: THandle;
begin
with Rect, FImage do
begin
ACanvas.RequiredState(csAllValid);
PaletteNeeded;
OldPalette := 0;
RestorePalette := False;
if FPalette <> 0 then
begin
OldPalette := SelectPalette(ACanvas.FHandle, FPalette, True);
RealizePalette(ACanvas.FHandle);
RestorePalette := True;
end;
BPP := GetDeviceCaps(ACanvas.FHandle, BITSPIXEL) *
GetDeviceCaps(ACanvas.FHandle, PLANES);
DoHalftone := (BPP <= 8) and (BPP < (FDIB.dsbm.bmBitsPixel * FDIB.dsbm.bmPlanes));
if DoHalftone then
begin
GetBrushOrgEx(ACanvas.FHandle, pt);
SetStretchBltMode(ACanvas.FHandle, HALFTONE);
SetBrushOrgEx(ACanvas.FHandle, pt.x, pt.y, @pt);
end else if not Monochrome then
SetStretchBltMode(ACanvas.Handle, STRETCH_DELETESCANS);
try
{ Call MaskHandleNeeded prior to creating the canvas handle since
it causes FreeContext to be called. }
if Transparent then MaskHandleNeeded;
Canvas.RequiredState(csAllValid);
if Transparent then
begin
Save := 0;
MaskDC := 0;
try
MaskDC := GDICheck(CreateCompatibleDC(0));
Save := SelectObject(MaskDC, FMaskHandle);
TransparentStretchBlt(ACanvas.FHandle, Left, Top, Right - Left,
Bottom - Top, Canvas.FHandle, 0, 0, FDIB.dsbm.bmWidth,
FDIB.dsbm.bmHeight, MaskDC, 0, 0);
finally
if Save <> 0 then SelectObject(MaskDC, Save);
if MaskDC <> 0 then DeleteDC(MaskDC);
end;
end
else
StretchBlt(ACanvas.FHandle, Left, Top, Right - Left, Bottom - Top,
Canvas.FHandle, 0, 0, FDIB.dsbm.bmWidth,
FDIB.dsbm.bmHeight, ACanvas.CopyMode);
finally
if RestorePalette then
SelectPalette(ACanvas.FHandle, OldPalette, True);
end;
end;
不要再深挖了，斜体部份很明了,功能就是将绘图内容从内存拷贝至窗口。ACanvas.FHandle即上面所说的消息传递进来的HDC。(ACanvas是TImage的祖先TGraphicControl的内部对像,Canvas在此为TBitmapCanvas实例)。
可能有点乱，因为我整理好了之后，再次阅读时，自已也迷糊了，仔细多看两遍吧。再提一下：TGraphicControl.Canvas与TImage.Canvas是两个实例，虽然TImage继承自TGraphicControl。
好了，我们再来看看为何使用窗口Canvas属性进行绘画时，没有使用双缓冲技术吧
二．窗口类的Canvas
其实也不能决对说窗口Canvas没有使用双缓冲技术，它有使用，但有限制。条件是在将窗口TForm.DoubleBuffered设为TRUE的前提下，在Pa
int事件函数里使用Canvas对像进行绘图动作。下面还是按照上面的方法来找出其中的缘由。先看一下TCustomForm.WMPaint消息处理函数：
procedure TCustomForm.WMPaint(var Message: TWMPaint);
var
DC: HDC;
PS: TPaintStruct;
begin
if not IsIconic(Handle) then
begin
ControlState := ControlState + [csCustomPaint];
inherited;
ControlState := ControlState - [csCustomPaint];
end
else
begin
DC := BeginPaint(Handle, PS);
DrawIcon(DC, 0, 0, GetIconHandle);
EndPaint(Handle, PS);
end;
end;
这个简单，基本只用考滤斜体部份代码，即调用基类同名函数，在此要追溯到TWinControl.WMPaint函数：
procedure TWinControl.WMPaint(var Message: TWMPaint);
var
DC, MemDC: HDC;
MemBitmap, OldBitmap: HBITMAP;
PS: TPaintStruct;
begin
if not FDoubleBuffered or (Message.DC <> 0) then
begin
if not (csCustomPaint in ControlState) and (ControlCount = 0) then
inherited
else
PaintHandler(Message);
end
else
begin
DC := GetDC(0);
MemBitmap := CreateCompatibleBitmap(DC, ClientRect.Right, ClientRect.Bottom);
ReleaseDC(0, DC);
MemDC := CreateCompatibleDC(0);
OldBitmap := SelectObject(MemDC, MemBitmap);
try
DC := BeginPaint(Handle, PS);
Perform(WM_ERASEBKGND, MemDC, MemDC);
Message.DC := MemDC;
WMPaint(Message);
Message.DC := 0;
BitBlt(DC, 0, 0, ClientRect.Right, ClientRect.Bottom, MemDC, 0, 0, SRCCOPY);
EndPaint(Handle, PS);
finally
SelectObject(MemDC, OldBitmap);
DeleteDC(MemDC);
DeleteObject(MemBitmap);
end;
end;
end;
好，先看下面的斜体部份，若将TForm.DoubleBuffered设为TRUE，那么将创建兼容DC即使用双缓冲技术。完了之后还是将会调用此函数，这时将会执行第一个斜体部份代码。也就是说，不管是否设置Form.DoubleBuffered为何值，始终会执行PaintHandler函数。只不过传递的参数的属性(DC)不同罢了。那就看看PaintHandler都干了些什么吧:
procedure TWinControl.PaintHandler(var Message: TWMPaint);
var
I, Clip, SaveIndex: Integer;
DC: HDC;
PS: TPaintStruct;
begin
DC := Message.DC;
if DC = 0 then DC := BeginPaint(Handle, PS);
try
if FControls = nil then PaintWindow(DC) else
begin
SaveIndex := SaveDC(DC);
Clip := SimpleRegion;
for I := 0 to FControls.Count - 1 do
with TControl(FControls[I]) do
if (Visible or (csDesigning in ComponentState) and
not (csNoDesignVisible in ControlStyle)) and
(csOpaque in ControlStyle) then
begin
Clip := ExcludeClipRect(DC, Left, Top, Left + Width, Top + Height);
if Clip = NullRegion then Break;
end;
if Clip <> NullRegion then PaintWindow(DC);
RestoreDC(DC, SaveIndex);
end;
PaintControls(DC, nil);
finally
if Message.DC = 0 then EndPaint(Handle, PS);
end;
end;
PaintWindow是虚函数，TCustomForm覆盖了它:
procedure TCustomForm.PaintWindow(DC: HDC);
begin
FCanvas.Lock;
try
FCanvas.Handle := DC;
try
if FDesigner <> nil then FDesigner.PaintGrid else Paint;
finally
FCanvas.Handle := 0;
end;
finally
FCanvas.Unlock;
end;
end;
可以看到，DC值赋给了FCanvas,触发了Paint事件。由此可以知，只有在将TForm.DoubleBuffered设为TRUE的情况下，并在OnPaint事件中调用Canvas属性时，才会使用双缓冲技术。
那在TForm的其它事件中使用Canvas绘图是什么情况呢：
constructor TCustomForm.CreateNew(AOwner: TComponent; Dummy: Integer);
begin
inherited Create(AOwner);
ControlStyle := [csAcceptsControls, csCaptureMouse, csClickEvents,
csSetCaption, csDoubleClicks];
Left := 0;
Top := 0;
Width := 320;
Height := 240;
FIcon := TIcon.Create;
FIcon.Width := GetSystemMetrics(SM_CXSMICON);
FIcon.Height := GetSystemMetrics(SM_CYSMICON);
FIcon.OnChange := IconChanged;
FCanvas := TControlCanvas.Create;
FCanvas.Control := Self;
FBorderIcons := [biSystemMenu, biMinimize, biMaximize];
FBorderStyle := bsSizeable;
…
再看一下TControlCanvas类的定义:
procedure TControlCanvas.CreateHandle;
begin
if FControl = nil then inherited CreateHandle else
begin
if FDeviceContext = 0 then
begin
with CanvasList.LockList do
try
if Count >= CanvasListCacheSize then FreeDeviceContext;
FDeviceContext := FControl.GetDeviceContext(FWindowHandle);
Add(Self);
finally
CanvasList.UnlockList;
end;
end;
Handle := FDeviceContext;
UpdateTextFlags;
end;
end;
上面代码中的FControl此时为TCustomForm,那么再看看TCustomForm.GetDeviceContext函数，它位于TWinControl类中定义：
function TWinControl.GetDeviceContext(var WindowHandle: HWnd): HDC;
begin
if csDesigning in ComponentState then
Result := GetDCEx(Handle, 0, DCX_CACHE or DCX_CLIPSIBLINGS)
else
Result := GetDC(Handle);
if Result = 0 then raise EOutOfResources.CreateRes(@SWindowDCError);
WindowHandle := FHandle;
end;
这段代码不解释也能看的明白了，只是使用了GetDC函数，而未使用我们想要的双缓冲。
结尾：在Delphi中绘图时可以使用TImage类来实现，比较方便。若要追求效率，推荐使用Win32Api。
声明：转载请保持此文档的完整性。
参考文献： 1.李维 《VCL构架剖析》 2.周爱民 《Delphi源代码分析》
附件：源码可以
到这里下载https://www.doczj.com/doc/b06248417.html,/DELPHI
我的联系方式 QQ:15793966 MSN:xiaoyunsoft@https://www.doczj.com/doc/b06248417.html, E_Mail:xiaoyunsoft@https://www.doczj.com/doc/b06248417.html,
唠叨两句：Delphi应用已不如前些年流行，现在Borland要卖它更是令众Fans不知何从。但这不代表Delphi已无用武之处，在我看来，桌面，小数据库，网络等应用仍是首选工具。希望朋友们不要跟风盲从。
/////////////////////