d2canvas.pas

XP风格的outbar.rar.有DELPHI,C++BULIDER的例子及源码

{**************************************************}
{                                                  }
{  Dream OutBar                                    }
{  Copyright (c) 1997-2001 Dream Company           }
{  http://www.dream-com.com                        }
{  e-mail: [e-mail]                   }
{                                                  }
{**************************************************}
unit d2Canvas;

interface
  Uses Classes, Controls, Graphics, Windows;

{ TThreadList class }

Type
  TThreadList = class
  private
    FList: TList;
    FLock: TRTLCriticalSection;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Add(Item: Pointer);
    procedure Clear;
    function  LockList: TList;
    procedure Remove(Item: Pointer);
    procedure UnlockList;
  end;

  TDCControlCanvas = class(TCanvas)
  private
    FControl: TControl;
    FDeviceContext: HDC;
    FLock:TRTLCriticalSection;
    FLockCount:Integer;
    FWindowHandle: HWnd;
    procedure SetControl(AControl: TControl);
  protected
    procedure CreateHandle; override;
  public
    constructor Create;
    destructor Destroy; override;

    procedure FreeHandle;
    Procedure Lock;
    Function TryLock:Boolean;
    Procedure UnLock;
    property Control: TControl read FControl write SetControl;
  end;

  procedure FreeDeviceContext;
  procedure FreeDeviceContexts;
  
Implementation
Const
  CanvasListCacheSize=4;

Var
  CanvasList:TThreadList;
  CounterLock: TRTLCriticalSection;
Type
  TPublicControl=Class(TControl);

// Free the first available device context

procedure FreeDeviceContext;
var
  I: Integer;
begin
  with CanvasList.LockList do
  try
    for I := 0 to Count-1 do
      with TDCControlCanvas(Items[I]) do
        if TryLock then
        try
          FreeHandle;
          Exit;
        finally
          Unlock;
        end;
  finally
    CanvasList.UnlockList;
  end;
end;

procedure FreeDeviceContexts;
var
  I: Integer;
begin
  with CanvasList.LockList do
  try
    for I := Count-1 downto 0 do
      with TDCControlCanvas(Items[I]) do
        if TryLock then
        try
          FreeHandle;
        finally
          Unlock;
        end;
  finally
    CanvasList.UnlockList;
  end;
end;

Constructor TDCControlCanvas.Create;
Begin
  Inherited;
  InitializeCriticalSection(FLock);
End;

destructor TDCControlCanvas.Destroy;
begin
  FreeHandle;
  inherited Destroy;
end;

procedure TDCControlCanvas.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 := TPublicControl(FControl).GetDeviceContext(FWindowHandle);
        Add(Self);
      finally
        CanvasList.UnlockList;
      end;
    end;
    Handle := FDeviceContext;
  end;
end;

procedure TDCControlCanvas.FreeHandle;
begin
  if FDeviceContext <> 0 then
  begin
    Handle := 0;
    CanvasList.Remove(Self);
    ReleaseDC(FWindowHandle, FDeviceContext);
    FDeviceContext := 0;
  end;
end;

procedure TDCControlCanvas.Lock;
begin
  EnterCriticalSection(CounterLock);
  Inc(FLockCount);
  LeaveCriticalSection(CounterLock);
  EnterCriticalSection(FLock);
end;

procedure TDCControlCanvas.SetControl(AControl: TControl);
begin
  if FControl <> AControl then
  begin
    FreeHandle;
    FControl := AControl;
  end;
end;

function TDCControlCanvas.TryLock: Boolean;
begin
  EnterCriticalSection(CounterLock);
  try
    Result := FLockCount = 0;
    if Result then Lock;
  finally
    LeaveCriticalSection(CounterLock);
  end;
end;

procedure TDCControlCanvas.Unlock;
begin
  LeaveCriticalSection(FLock);
  EnterCriticalSection(CounterLock);
  Dec(FLockCount);
  LeaveCriticalSection(CounterLock);
end;

{ TThreadList }

constructor TThreadList.Create;
begin
  inherited Create;
  InitializeCriticalSection(FLock);
  FList := TList.Create;
end;

destructor TThreadList.Destroy;
begin
  LockList;    // Make sure nobody else is inside the list.
  try
    FList.Free;
    inherited Destroy;
  finally
    UnlockList;
    DeleteCriticalSection(FLock);
  end;
end;

procedure TThreadList.Add(Item: Pointer);
begin
  LockList;
  try
    if FList.IndexOf(Item) = -1 then
      FList.Add(Item);
  finally
    UnlockList;
  end;
end;

procedure TThreadList.Clear;
begin
  LockList;
  try
    FList.Clear;
  finally
    UnlockList;
  end;
end;

function  TThreadList.LockList: TList;
begin
  EnterCriticalSection(FLock);
  Result := FList;
end;

procedure TThreadList.Remove(Item: Pointer);
begin
  LockList;
  try
    FList.Remove(Item);
  finally
    UnlockList;
  end;
end;

procedure TThreadList.UnlockList;
begin
  LeaveCriticalSection(FLock);
end;

Initialization
  InitializeCriticalSection(CounterLock);
  CanvasList := TThreadList.Create;

Finalization
  DeleteCriticalSection(CounterLock);

end.