双缓冲绘图技术在Delphi中的实现

摘要：双缓冲绘图技术在Delphi中的实现
说明：假设读者熟悉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(ACanvas: 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的前提下，在Paint事件函数里使用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函数，而未使用我们想要的双缓冲。