{*******************************************************}
{ }
{ 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.