Background Intelligent Transfer Service nutzen

[HeikoAdams]

So, hier nochmal eine leicht modifizierte Version, in der noch ein paar Details geändert worden sind:

Delphi-Quellcode:

{*******************************************************}
{                                                       }
{       Unit for using Microsoft BITS                   }
{                                                       }
{       Copyright (C) 2010 Heiko Adams                  }
{                                                       }
{*******************************************************}

unit RifBackgroundCopyService;

interface

uses JwaWindows, ExtActns, Types, SysUtils;

type
  TBackgroundCopyService = class
  private
    FAttempts: Byte;
    FJobId: TGUID;
    CopyMngr: IBackgroundCopyManager;
    CopyJob: IBackgroundCopyJob;

    procedure DownloadUrl(const aURL, aDest: WideString;
      const aDisplayName: WideString;
      const aJobType: BG_JOB_TYPE = BG_JOB_TYPE_DOWNLOAD);
    procedure DownloadMultiUrl(const aURL, aDest: TWideStringDynArray;
      const aDisplayName: WideString;
      const aJobType: BG_JOB_TYPE = BG_JOB_TYPE_DOWNLOAD);

    function WaitForDownload(const aJobType: BG_JOB_TYPE;
      const aDownloadFeedback: TDownloadProgressEvent): BG_JOB_STATE;
    function GetNewJob(const aDisplayName: WideString;
      const aJobType: BG_JOB_TYPE; var aJob: IBackgroundCopyJob): Integer;
    function GetCopyJobError: HRESULT;
    function ResumeJob(const aDownloadFeedback: TDownloadProgressEvent): Boolean;
  public
    constructor Create;
    destructor Destroy; override;

    function UploadFile(const aURL, aDest: WideString;
      const aDownloadFeedback: TDownloadProgressEvent;const aDisplayName: WideString): Boolean;
    function DownloadFile(const aURL, aDest: WideString;
      const aDownloadFeedback: TDownloadProgressEvent;const aDisplayName: WideString): Boolean;
    function DownloadFiles(const aURL, aDest: TWideStringDynArray;
      const aDownloadFeedback: TDownloadProgressEvent;const aDisplayName: WideString): Boolean; experimental;

    property AttemptsOnFailure: Byte read FAttempts write FAttempts;
    property JobId: TGUID read FJobId;
  end;

implementation

uses JclWin32, ComObj, JclSysInfo, ActiveX;

constructor TBackgroundCopyService.Create();
begin
  FAttempts := 3;

  if not Succeeded(CoCreateInstance(CLSID_BackgroundCopyManager, nil,
    CLSCTX_LOCAL_SERVER, IID_IBackgroundCopyManager, CopyMngr)) then
    RaiseLastOSError;
end;

destructor TBackgroundCopyService.Destroy;
begin
  inherited;

  if Assigned(CopyJob) then
    CopyJob := nil;

  if Assigned(CopyMngr) then
    CopyMngr := nil;
end;

function TBackgroundCopyService.UploadFile(const aURL, aDest: WideString;
  const aDownloadFeedback: TDownloadProgressEvent;
  const aDisplayName: WideString): Boolean;
var
  nCount: Byte;
begin
  nCount := 1;
  DownloadUrl(aURL, aDest, aDisplayName, BG_JOB_TYPE_UPLOAD);

  try
    repeat
      Result := ResumeJob(aDownloadFeedback);
      Inc(nCount);
    until Result or (nCount >= FAttempts);
  finally
    CopyJob := nil;
  end;
end;

function TBackgroundCopyService.DownloadFile(const aURL, aDest: WideString;
  const aDownloadFeedback: TDownloadProgressEvent;
  const aDisplayName: WideString): Boolean;
var
  nCount: Byte;  
begin
  nCount := 1;
  DownloadUrl(aURL, aDest, aDisplayName, BG_JOB_TYPE_DOWNLOAD);

  try
    repeat
      Result := ResumeJob(aDownloadFeedback);
      Inc(nCount);
    until Result or (nCount >= FAttempts);
  finally
    CopyJob := nil;
  end;
end;

function TBackgroundCopyService.DownloadFiles(const aURL, aDest: TWideStringDynArray;
  const aDownloadFeedback: TDownloadProgressEvent;
  const aDisplayName: WideString): Boolean;
var
  nCount: Byte;  
begin
  nCount := 1;
  DownloadMultiUrl(aURL, aDest, aDisplayName, BG_JOB_TYPE_DOWNLOAD);

  try
    repeat
      Result := ResumeJob(aDownloadFeedback);
      Inc(nCount);
    until Result or (nCount >= FAttempts);
  finally
    CopyJob := nil;
  end;
end;

function TBackgroundCopyService.GetNewJob(const aDisplayName: WideString;
  const aJobType: BG_JOB_TYPE; var aJob: IBackgroundCopyJob): Integer;
begin
  Result := CopyMngr.CreateJob(PWideChar(aDisplayName), aJobType, FJobId, aJob);
end;

function TBackgroundCopyService.GetCopyJobError: HRESULT;
var
  CopyError: IBackgroundCopyError;
  Context: BG_ERROR_CONTEXT;
begin
  CopyJob.GetError(CopyError);
  
  try
    CopyJob.Cancel;
    CopyError.GetError(Context, Result);
  finally
    CopyError := nil;
  end;
end;

function TBackgroundCopyService.ResumeJob(const aDownloadFeedback: TDownloadProgressEvent): Boolean;
var
  JobStatus: BG_JOB_STATE;
  JobType: BG_JOB_TYPE;
begin      
  Result := False;

  with CopyJob do
  begin
    GetType(JobType);
    Resume();
  end;
  
  JobStatus := WaitForDownload(JobType, aDownloadFeedback);

  if (JobStatus in [BG_JOB_STATE_TRANSFERRED,
    BG_JOB_STATE_ERROR, BG_JOB_STATE_TRANSIENT_ERROR]) then
    Result := (JobStatus = BG_JOB_STATE_TRANSFERRED);

  if Result then
    CopyJob.Complete
  else
    RaiseLastOSError(GetCopyJobError);
end;

procedure TBackgroundCopyService.DownloadUrl(const aURL, aDest: WideString;
  const aDisplayName: WideString; const aJobType: BG_JOB_TYPE = BG_JOB_TYPE_DOWNLOAD);
begin
  if Assigned(CopyJob) then
    CopyJob := nil;

  if not Succeeded(GetNewJob(aDisplayName, aJobType, CopyJob)) then
    RaiseLastOSError;

  if not Succeeded(CopyJob.AddFile(PWideChar(aURL), PWideChar(aDest))) then
    RaiseLastOSError;
end;

procedure TBackgroundCopyService.DownloadMultiUrl(const aURL, aDest: TWideStringDynArray;
  const aDisplayName: WideString; const aJobType: BG_JOB_TYPE = BG_JOB_TYPE_DOWNLOAD);
var
  DownloadInfo: PBgFileInfo;
  Info: array of BG_FILE_INFO;
  nCount: Integer;
begin
  if Assigned(CopyJob) then
    CopyJob := nil;

  if not Succeeded(GetNewJob(aDisplayName, aJobType, CopyJob)) then
    RaiseLastOSError;

  SetLength(Info, Length(aUrl));
  ZeroMemory(@Info, SizeOf(Info));

  try
    for nCount := Low(aURL) to High(aURL) do
      with Info[nCount] do
      begin
        RemoteName := PWideChar(aUrl[nCount]);
        LocalName := PWideChar(aDest[nCount]);
      end;

    DownloadInfo := @Info;
    nCount := Length(Info);

    if not Succeeded(CopyJob.AddFileSet(nCount, DownloadInfo)) then
      RaiseLastOSError;
  finally
    SetLength(Info, 0);
  end;
end;

function TBackgroundCopyService.WaitForDownload(const aJobType: BG_JOB_TYPE;
  const aDownloadFeedback: TDownloadProgressEvent): BG_JOB_STATE;
var
  JobProgress: BG_JOB_PROGRESS;
  hTimer: THandle;
  DueTime: TLargeInteger;
  bCanceled: boolean;
  sName: PWideChar;
  Status: TURLDownloadStatus;
begin
  CopyJob.GetDisplayName(sName);
  bCanceled := False;
  DueTime := -10000000;
  hTimer := CreateWaitableTimerW(nil, false, sName);

  if (aJobType = BG_JOB_TYPE_DOWNLOAD) then
    Status := dsDownloadingData
  else
    Status := dsUploadingData;

  try
    SetWaitableTimer(hTimer, DueTime, 1000, nil, nil, false);

    repeat
      CopyJob.GetState(Result);

      if (Result in [BG_JOB_STATE_TRANSFERRING, BG_JOB_STATE_TRANSFERRED]) then
      begin
        CopyJob.GetProgress(JobProgress);
        aDownloadFeedback(nil, JobProgress.BytesTransferred, JobProgress.BytesTotal,
          Status, '', bCanceled);

        if bCanceled then
          break;
      end;

      WaitForSingleObject(hTimer, INFINITE);
    until (Result in [BG_JOB_STATE_TRANSFERRED, BG_JOB_STATE_ERROR, BG_JOB_STATE_TRANSIENT_ERROR]);
  finally
    CancelWaitableTimer(hTimer);
    CloseHandle(hTimer);
  end;
end;

end.

Edit 10.07.2010: noch ein paar kleine Modifikationen eingefügt.