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.

[HeikoAdams]

Einen hab ich noch:

SetNotifyInterface wird unterstützt, um z.B. Aktionen nach dem (erfolglosen) Download durchzuführen.

Delphi-Quellcode:

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

unit BackgroundCopyService;

interface

uses JwaWindows, ExtActns, Types, SysUtils;

type
  EInterfaceNotSet = Exception;
  cBackgroundCopyCallback = class(TObject, IUnknown, IBackgroundCopyCallback)
  private
    function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
    function _AddRef: Integer; stdcall;
    function _Release: Integer; stdcall;
    function JobTransferred(aJob: IBackgroundCopyJob): HResult; stdcall;
    function JobError(aJob: IBackgroundCopyJob; aError: IBackgroundCopyError): HResult; stdcall;
    function JobModification(aJob: IBackgroundCopyJob; aReserved: DWord): HResult; stdcall;
  end;

  TBackgroundCopyService = class
  private
    FAttempts: Byte;
    FJobId: TGUID;
    FNotifyFlags: Cardinal;
    CopyMngr: IBackgroundCopyManager;
    CopyJob: IBackgroundCopyJob;
    FCopyCallback: cBackgroundCopyCallback;

    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): HRESULT;
    function ExecuteAfterDownload: HResult;
  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;
    property CopyCallbackInterface: cBackgroundCopyCallback read FCopyCallback write FCopyCallback;
    property NotifyFlags: Cardinal read FNotifyFlags write FNotifyFlags;
  end;

  const errInterfaceNotSet = 'Could not set BackgroundCopyCallback Interface';

implementation

uses JclWin32, ComObj, JclSysInfo, ActiveX;

function cBackgroundCopyCallback._AddRef: Integer;
begin
  Result := 0;
end;

function cBackgroundCopyCallback._Release: Integer;
begin
  Result := 0;
end;

function cBackgroundCopyCallback.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
  if(GetInterface(IID,Obj)) then
  begin
    Result := 0
  end else
  begin
    Result := E_NOINTERFACE;
  end;
end;

function cBackgroundCopyCallback.JobTransferred(aJob: IBackgroundCopyJob): HResult;
begin
  Result := S_OK;
end;

function cBackgroundCopyCallback.JobError(aJob: IBackgroundCopyJob; aError: IBackgroundCopyError): HResult;
begin
  Result := S_OK;
end;

function cBackgroundCopyCallback.JobModification(aJob: IBackgroundCopyJob; aReserved: DWord): HResult;
begin
  Result := S_OK;
end;

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;
  nError: HRESULT;
begin
  nCount := 1;
  DownloadUrl(aURL, aDest, aDisplayName, BG_JOB_TYPE_UPLOAD);

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

  if not Result then
    RaiseLastOSError(nError);  
end;

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

  try
    if Assigned(FCopyCallback) and
      not Succeeded(ExecuteAfterDownload) then
      raise EInterfaceNotSet.Create(errInterfaceNotSet);
      
    repeat
      nError := ResumeJob(aDownloadFeedback);
      Result := (nError = S_OK);
      Inc(nCount);
    until Result or (nCount >= FAttempts);
  finally
    CopyJob := nil;
  end;

  if not Result then
    RaiseLastOSError(nError);
end;

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

  try
    if Assigned(FCopyCallback) and
      not Succeeded(ExecuteAfterDownload) then
      raise EInterfaceNotSet.Create(errInterfaceNotSet);

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

  if not Result then
    RaiseLastOSError(nError);
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): HRESULT;
var
  JobStatus: BG_JOB_STATE;
  JobType: BG_JOB_TYPE;
  bSuccess: Boolean;
begin
  bSuccess := 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
    bSuccess := (JobStatus = BG_JOB_STATE_TRANSFERRED);

  if bSuccess then
  begin
    CopyJob.Complete;
    Result := S_OK;
  end
  else
    Result := 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;
const
  nPeriod: Word = 1000;
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, nPeriod, 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;

function TBackgroundCopyService.ExecuteAfterDownload: HResult;
begin
  Result := CopyJob.SetNotifyInterface(FCopyCallback);

  if Succeeded(Result) then
    CopyJob.SetNotifyFlags(FNotifyFlags);
end;

end.

[Sharky]

Hai Haiko,

ich glaube es wäre für die Lesbarkeit des Threads besser wenn Du deinen Quellcode nicht jedesmal komplett einträgst sondern als Datei anhängst.

Danke!

[HeikoAdams]

oki doki