interface

uses
  Classes, Windows, SyncObjs, SysUtils, ADODB;

type
  TADOConnectionPool = class(TObject)
  private
    FObjList:TThreadList;
    FTimeout: Integer;
    FMaxCount: Integer;
    FSemaphore: Cardinal;
    FConnectionString: string;
    function CreateNewInstance(List:TList): TADOConnection;
    function GetLock(List:TList;Index: Integer): Boolean;
  public
    property ConnectionString:string read FConnectionString write FConnectionString;
    property Timeout:Integer read FTimeout write FTimeout;
    property MaxCount:Integer read FMaxCount;

    constructor Create(ACapicity:Integer=15);overload;
    destructor Destroy;override;
    function LockConnection: TADOConnection;
    procedure UnlockConnection(var Value: TADOConnection);
  end;

var
  ConnectionPool: TADOConnectionPool;

implementation

constructor TADOConnectionPool.Create(ACapicity:Integer=15);
begin
  FObjList:=TThreadList.Create;
  FTimeout := 15000;
  FMaxCount := ACapicity;
  FSemaphore := CreateSemaphore(nil, FMaxCount, FMaxCount, nil);    
end;

function TADOConnectionPool.CreateNewInstance(List:TList): TADOConnection;
var
  p: TADOConnection;
begin
  try
    Result := nil;
    p := TADOConnection.Create(nil);
    p.ConnectionString := ConnectionString;
    p.LoginPrompt := False;
    p.Connected:=True;
    p.Tag := 1;
    List.Add(p);
    Result := p;
    p.Free;
  except
    Exit;
  end;
end;

destructor TADOConnectionPool.Destroy;
var
  i: Integer;
  List:TList;
begin
  List:=FObjList.LockList;
  try
    for i := List.Count - 1 downto 0 do
    begin
      TADOConnection(List[i]).Free;
      Dispose(List[i]);
    end;
  finally
    FObjList.UnlockList;
  end;
  FObjList.Free;
  FObjList := nil;
  CloseHandle(FSemaphore);
  inherited Destroy;
end;

function TADOConnectionPool.GetLock(List:TList;Index: Integer): Boolean;
begin
  try
    Result := TADOConnection(List[Index]).Tag = 0;
    if Result then
      TADOConnection(List[Index]).Tag := 1;
  except
    Exit;
  end;
end;

function TADOConnectionPool.LockConnection: TADOConnection;
var
  i,WaitResult: Integer;
  List:TList;
begin
  try
    Result := nil;
    WaitResult:= WaitForSingleObject(FSemaphore, Timeout);
    List:=FObjList.LockList;
    try
      for i := 0 to List.Count - 1 do
      begin
        if GetLock(List,i) then
        begin
          Result := TADOConnection(List[i]);
          Exit;
        end;
      end;
      if List.Count < MaxCount then
        Result := CreateNewInstance(List);
    finally
      FObjList.UnlockList;
    end;
  except
    Exit;
  end;
end;

procedure TADOConnectionPool.UnlockConnection(var Value: TADOConnection);
var
  List:TList;
begin
  try
    List:=FObjList.LockList;
    try
      TADOConnection(List[List.IndexOf(Value)]).Tag :=0;
      ReleaseSemaphore(FSemaphore, 1, nil);
    finally
      FObjList.UnlockList;
    end;
  except
    Exit;
  end;
end;

initialization
  ConnectionPool := TADOConnectionPool.Create();
finalization
  ConnectionPool.Free;

end.