type
  TClipboardExt = class(TClipboard)
  public
    procedure Open; override;
  end;

  TClipboardHelper = class helper for TClipboard
  public
    class function GetLockInfo: String;
  end;

procedure InstallExtClipboard;
begin
  SetClipboard(TClipboardExt.Create).Free;
end;

procedure TClipboardExt.Open;
var
  LockInfo: String;
begin
  try
    inherited Open;
  except
    on E: Exception do
    begin
      LockInfo := GetLockInfo;
      if LockInfo <> '' then
        E.Message := E.Message + Format( ' (locked by %s)', [LockInfo]);
      raise;
    end;
  end;
end;

class function TClipboardHelper.GetLockInfo: String;
var
  i: Integer;
  Buffer: array[0..1024] of Char;
  Wnd: HWND;
begin
  Result := '';
  Wnd := GetOpenClipboardWindow();
  if Wnd = 0 then Exit;

  Result := Format('HWND=%x', [Wnd]);

  i := GetWindowText( Wnd, Buffer, Length(Buffer));
  if i > 0 then
    Result := Result + '; Caption=' + Buffer;

  i := GetClassName( Wnd, Buffer, Length(Buffer));
  if i > 0 then
    Result := Result + '; Class=' + Buffer;

  if GetCurrentThreadId <> MainThreadID then
    Result := Result + '; ThreadID=' + IntToHex( GetCurrentThreadId, 8);
end;

initialization
  InstallExtClipboard;