在SQL SERVER中要进行大数据量的复制或在两台机器中进行大数据量的复制，最好的工具是DTS.如何在Delphi中调用DTS,笔者经查阅网上资料，参照相关代码终于搞定。再次代码贴出来，希望能够给有这个方面需求的人所有帮助，同时也感谢delphibbs上的好人。
unit uFrmMain;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, OleServer, DTS_TLB, DTSEvents, StdCtrls;
type
TFrmMain = class(TForm)
btnLoadFile: TButton;
dlgOpen1: TOpenDialog;
edtFileName: TEdit;
lbl1: TLabel;
btnExecute: TButton;
mmoInfo: TMemo;
procedure btnExecuteClick(Sender: TObject);
procedure btnLoadFileClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
oPackage: Package;
procedure AddItem(AText: string);
procedure RunPackage(AFileName: string);
function InternalPackageStartEvent(Sender: TObject; const EventSource: WideString): HResult;
function InternalPackageFinishEvent(Sender: TObject; const EventSource: WideString): HResult;
function InternalPackageErrorEvent(Sender: TObject; const EventSource: WideString;
ErrorCode: Integer; const Source: WideString; const Description: WideString;
const HelpFile: WideString; HelpContext: Integer;
const IDofInterfaceWithError: WideString;
var pbCancel: WordBool): HResult;
function InternalPackageProgressEvent(Sender: TObject;
const EventSource: WideString; const ProgressDescription: WideString;
PercentComplete: Integer; ProgressCountLow: Integer;
ProgressCountHigh: Integer): HResult;
function InternalPackageQueryCancelEvent(Sender: TObject;
const EventSource: WideString; var pbCancel: WordBool): HResult;
function GetDTSError(APackage: Package): string;
public
{ Public declarations }
end;
var
FrmMain: TFrmMain;
implementation
{$R *.dfm}
procedure TFrmMain.AddItem(AText: string);
begin
mmoInfo.Lines.Add(DateTimeToStr(Now) + ' ' + AText)
end;
procedure TFrmMain.RunPackage(AFileName: string);
var
oStep: Step;
oTask: Task;
oExecPkg: ExecutePackageTask;
oDTSEvent: TDTSPackageEvents;
begin
oStep := oPackage.Steps.New;
oTask := oPackage.Tasks.New('DTSExecutePackageTask');
oExecPkg := ExecutePackageTask(oTask.CustomTask);
with oExecPkg do
begin
Name := 'ExecPkgTask';
ServerName := '(local)';
UseTrustedConnection := True;
//Use something like this for non NT authentication
//ServerUserName = "sa"
//ServerPassword = 'Request this password, don't include it in code
FileName := AFileName;
end;
with oStep do
begin
TaskName := oExecPkg.Name;
Name := 'ExecPkgStep';
ExecuteInMainThread := False;
end;
oPackage.Steps.Add(oStep);
oPackage.Tasks.Add(oTask);
oDTSEvent := TDTSPackageEvents.Create(nil);
oDTSEvent.OnStart := InternalPackageStartEvent;
oDTSEvent.OnFinish := InternalPackageFinishEvent;
oDTSEvent.OnError := InternalPackageErrorEvent;
oDTSEvent.OnProgress := InternalPackageProgressEvent;
oDTSEvent.OnQueryCancel := InternalPackageQueryCancelEvent;
oDTSEvent.Connect(oPackage);
oPackage.Execute;
oExecPkg := nil;
oTask := nil;
oStep := nil;
oPackage.UnInitialize;
end;
procedure TFrmMain.btnExecuteClick(Sender: TObject);
begin
RunPackage(edtFileName.Text);
end;
procedure TFrmMain.btnLoadFileClick(Sender: TObject);
begin
if dlgOpen1.Execute then
begin
edtFileName.Text := dlgOpen1.FileName;
btnExecute.Enabled := True;
end;
end;
procedure TFrmMain.FormCreate(Sender: TObject);
begin
oPackage := CoPackage.Create;
end;
function TFrmMain.InternalPackageErrorEvent(Sender: TObject;
const EventSource: WideString; ErrorCode: Integer; const Source,
Description, HelpFile: WideString; HelpContext: Integer;
const IDofInterfaceWithError: WideString;
var pbCancel: WordBool): HResult;
begin
AddItem(EventSource + ' Error: ' + GetDTSError(oPackage));
Result := S_OK;
end;
function TFrmMain.InternalPackageFinishEvent(Sender: TObject;
const EventSource: WideString): HResult;
begin
AddItem(EventSource + ' Finished');
Result := S_OK;
end;
function TFrmMain.InternalPackageProgressEvent(Sender: TObject;
const EventSource, ProgressDescription: WideString; PercentComplete,
ProgressCountLow, ProgressCountHigh: Integer): HResult;
begin
AddItem(Format(EventSource + ' Progress %d/%d %d', [PercentComplete, ProgressCountLow,
ProgressCountHigh]));
Result := S_OK;
end;
function TFrmMain.InternalPackageQueryCancelEvent(Sender: TObject;
const EventSource: WideString; var pbCancel: WordBool): HResult;
begin
AddItem(EventSource + ' QueryCancel');
Result := S_OK;
end;
function TFrmMain.InternalPackageStartEvent(Sender: TObject;
const EventSource: WideString): HResult;
begin
AddItem(EventSource + ' Start');
Result := S_OK;
end;
function TFrmMain.GetDTSError(APackage: Package): string;
var
I: Integer;
iErrNum: Integer;
sDescr: WideString;
sSource: WideString;
sHelpFile: WideString;
iHelpContext: Integer;
sError: WideString;
begin
Result := '';
for I := 1 to APackage.Steps.Count do
begin
with APackage.Steps.Item(I) do
begin
if ExecutionStatus = DTSStepExecStat_Completed then
begin
if ExecutionResult = DTSStepExecResult_Failure then
GetExecutionErrorInfo(iErrNum, sSource, sDescr, sHelpFile,
iHelpContext, sError);
Result := Result + #13#10 +
'步骤：' + Name + '出错，错误代码：' + IntToHex(iErrNum, 8) + #13#10 +
'描述：' + sDescr;
end;
end;
end;
end;
end.
/* DTS Event 单元 */
{ *******************
**********************************************************
WARNING: This component file was generated using the EventSinkImp utility.
The contents of this file will be overwritten everytime EventSinkImp
is asked to regenerate this sink component.
NOTE: When using this component at the same time with the XXX_TLB.pas in
your Delphi projects, make sure you always put the XXX_TLB unit name
AFTER this component unit name in the USES clause of the interface
section of your unit; otherwise you may get interface conflict
errors from the Delphi compiler.
EventSinkImp is written by Binh Ly (bly@techvanguards.com)
*****************************************************************************
//Sink Classes//
TDTSPackageEvents
}
{$IFDEF VER100}
{$DEFINE D3}
{$ENDIF}
//SinkUnitName//
unit DTSEvents;
interface
uses
Windows, ActiveX, Classes, ComObj, OleCtrls
//SinkUses//
, StdVCL
, DTS_TLB
;
type
{ backward compatibility types }
{$IFDEF D3}
OLE_COLOR = TOleColor;
{$ENDIF}
TDTSEventsBaseSink = class (TComponent, IUnknown, IDispatch)
protected
{ IUnknown }
function QueryInterface(const IID: TGUID; out Obj): HResult; {$IFNDEF D3} override; {$ENDIF} stdcall;
function _AddRef: Integer; stdcall;
function _Release: Integer; stdcall;
{ IDispatch }
function GetIDsOfNames(const IID: TGUID; Names: Pointer;
NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; virtual; stdcall;
function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; virtual; stdcall;
function GetTypeInfoCount(out Count: Integer): HResult; virtual; stdcall;
function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; virtual; stdcall;
protected
FCookie: integer;
FCP: IConnectionPoint;
FSinkIID: TGUID;
FSource: IUnknown;
function DoInvoke (DispID: Integer; const IID: TGUID; LocaleID: Integer;
Flags: Word; var dps: TDispParams; pDispIds: PDispIdList;
VarResult, ExcepInfo, ArgErr: Pointer): HResult; virtual; abstract;
public
destructor Destroy; override;
procedure Connect (const ASource: IUnknown);
procedure Disconnect;
property SinkIID: TGUID read FSinkIID write FSinkIID;
property Source: IUnknown read FSource;
end;
//SinkImportsForwards//
//SinkImports//
//SinkIntfStart//
//SinkEventsForwards//
TPackageEventsOnStartEvent = function (Sender: TObject; const EventSource: WideString): HResult of object;
TPackageEventsOnFinishEvent = function (Sender: TObject; const EventSource: WideString): HResult of object;
TPackageEventsOnErrorEvent = function (Sender: TObject; const EventSource: WideString; ErrorCode: Integer; const Source: WideString; const Description: WideString; const HelpFile: WideString; HelpContext: Integer; const IDofInterfaceWithError: WideString; var pbCancel: WordBool): HResult of object;
TPackageEventsOnProgressEvent = function (Sender: TObject; const EventSource: WideString; const ProgressDescription: WideString; PercentComplete: Integer; ProgressCountLow: Integer; ProgressCountHigh: Integer): HResult of object;
TPackageEventsOnQueryCancelEvent = function (Sender: TObject; const EventSource: WideString; var pbCancel: WordBool): HResult of object;
//SinkComponent//
TDTSPackageEvents = class (TDTSEventsBaseSink , PackageEvents)
protected
function DoInvoke (DispID: Integer; const IID: TGUID; LocaleID: Integer;
Flags: Word; var dps: TDispParams; pDispIds: PDispIdList;
VarResult, ExcepInfo, ArgErr: Pointer): HResult; override;
{ PackageEvents }
function PackageEvents.OnStart = DoOnStart;
function PackageEvents.OnFinish = DoOnFinish;
function PackageEvents.OnError = DoOnError;
function PackageEvents.OnProgress = DoOnProgress;
function PackageEvents.OnQueryCancel = DoOnQueryCancel;
public
{ system methods }
constructor Create (AOwner: TComponent); override;
protected
//SinkInterface//
function DoOnStart(const EventSource: WideString): HResult; stdcall;
function DoOnFinish(const EventSource: WideString): HResult; stdcall;
function DoOnError(const EventSource: WideString; ErrorCode: Integer; const Source: WideString; const Description: WideString; const HelpFile: WideString; HelpContext: Integer; const IDofInterfaceWithError: WideString; var pbCancel: WordBool): HResult; stdcall;
function DoOnProgress(const EventSource: WideString; const ProgressDescription: WideString; PercentComplete: Integer; ProgressCountLow: Integer; ProgressCountHigh: Integer): HResult; stdcall;
function DoOnQueryCancel(const EventSource: WideString; var pbCancel: WordBool): HResult; stdcall;
protected
//SinkEventsProtected//
FOnStart: TPackageEventsOnStartEvent;
FOnFinish: TPackageEventsOnFinishEvent;
FOnError: TPackageEventsOnErrorEvent;
FOnProgress: TPackageEventsOnProgressEvent;
FOnQueryCancel: TPackageEventsOnQueryCancelEvent;
published
//SinkEventsPublished//
property OnStart: TPackageEventsOnStartEvent read FOnStart write FOnStart;
property OnFinish: TPackageEventsOnFinishEvent read FOnFinish write FOnFinish;
property OnError: TPackageEventsOnErrorEvent read FOnError write FOnError;
property OnProgress: TPackageEventsOnProgressEvent read FOnProgress write FOnProgress;
property OnQueryCancel: TPackageEventsOnQueryCancelEvent read FOnQueryCancel write FOnQueryCancel;
end;
//SinkIntfEnd//
procedure Register;
implementation
uses
SysUtils;
{ globals }
procedure BuildPositionalDispIds (pDispIds: PDispIdList; const dps: TDispParams);
var
i: integer;
begin
Assert (pDispIds <> nil);
{ by default, directly arrange in reverse order }
for i := 0 to dps.cArgs - 1 do
pDispIds^ [i] := dps.cArgs - 1 - i;
{ check for named args }
if (dps.cNamedArgs <= 0) then Exit;
{ parse named args }
for i := 0 to dps.cNamedArgs - 1 do
pDispIds^ [dps.rgdispidNamedArgs^ [i]] := i;
end;
{ TDTSEventsBaseSink }
function TDTSEventsBaseSink.GetIDsOfNames(const IID: TGUID; Names: Pointer;
NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;
begin
Result := E_NOTIMPL;
end;
function TDTSEventsBaseSink.GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult;
begin
Result := E_NOTIMPL;
pointer (TypeInfo) := nil;
end;
function TDTSEventsBaseSink.GetTypeInfoCount(out Count: Integer): HResult;
begin
Result := E_NOTIMPL;
Count := 0;
end;
function TDTSEventsBaseSink.Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult;
var
dps: TDispParams absolute Params;
bHasParams: boolean;
pDispIds: PDispIdList;
iDispIdsSize: integer;
begin
{ validity checks }
if (Flags AND DISPATCH_METHOD = 0) then
raise Exception.Create (
Format ('%s only supports sinking of method calls!', [ClassName]
));
{ build pDispIds array. this maybe a bit of overhead but it allows us to
sink named-argument calls such as Excel's AppEvents, etc!
}
pDispIds := nil;
iDispIdsSize := 0;
bHasParams := (dps.cArgs > 0);
if (bHasParams) then
begin
iDispIdsSize := dps.cArgs * SizeOf (TDispId);
GetMem (pDispIds, iDispIdsSize);
end; { if }
try
{ rearrange dispids properly }
if (bHasParams) then BuildPositionalDispIds (pDispIds, dps);
Result := DoInvoke (DispId, IID, LocaleID, Flags, dps, pDispIds, VarResult, ExcepInfo, ArgErr);
finally
{ free pDispIds array }
if (bHasParams) then FreeMem (pDispIds, iDispIdsSize);
end; { finally }
end;
function TDTSEventsBaseSink.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
if (GetInterface (IID, Obj)) then
begin
Result := S_OK;
Exit;
end
else
if (IsEqualIID (IID, FSinkIID)) then
if (GetInterface (IDispatch, Obj)) then
begin
Result := S_OK;
Exit;
end;
Result := E_NOINTERFACE;
pointer (Obj) := nil;
end;
function TDTSEventsBaseSink._AddRef: Integer;
begin
Result := 2;
end;
function TDTSEventsBaseSink._Release: Integer;
begin
Result := 1;
end;
destructor TDTSEventsBaseSink.Destroy;
begin
Disconnect;
inherited;
end;
procedure TDTSEventsBaseSink.Connect (const ASource: IUnknown);
var
pcpc: IConnectionPointContainer;
begin
Assert (ASource <> nil);
Disconnect;
try
OleCheck (ASource.QueryInterface (IConnectionPointContainer, pcpc));
OleCheck (pcpc.FindConnectionPoint (FSinkIID, FCP));
OleCheck (FCP.Advise (Self, FCookie));
FSource := ASource;
except
raise Exception.Create (Format ('Unable to connect %s.'#13'%s',
[Name, Exception (ExceptObject).Message]
));
end; { finally }
end;
procedure TDTSEventsBaseSink.Disconnect;
begin
if (FSource = nil) then Exit;
try
OleCheck (FCP.Unadvise (FCookie));
FCP := nil;
FSource := nil;
except
pointer (FCP) := nil;
pointer (FSource) := nil;
end; { except }
end;
//SinkImplStart//
function TDTSPackageEvents.DoInvoke (DispID: Integer; const IID: TGUID; LocaleID: Integer;
Flags: Word; var dps: TDispParams; pDispIds: PDispIdList;
VarResult, ExcepInfo, ArgErr: Pointer): HResult;
type
POleVariant = ^OleVariant;
begin
Result := DISP_E_MEMBERNOTFOUND;
//SinkInvoke//
//SinkInvokeEnd//
end;
constructor TDTSPackageEvents.Create (AOwner: TComponent);
begin
inherited Create (AOwner);
//SinkInit//
FSinkIID := PackageEvents;
end;
//SinkImplementation//
function TDTSPackageEvents.DoOnStart(const EventSource: WideString): HResult;
begin
Result := S_OK;
if not Assigned (OnStart) then System.Exit;
Result := OnStart (Self, EventSource);
end;
function TDTSPackageEvents.DoOnFinish(const EventSource: WideString): HResult;
begin
Result := S_OK;
if not Assigned (OnFinish) then System.Exit;
Result := OnFinish (Self, EventSource);
end;
function TDTSPackageEvents.DoOnError(const EventSource: WideString; ErrorCode: Integer; const Source: WideString; const Description: WideString; const HelpFile: WideString; HelpContext: Integer; const IDofInterfaceWithError: WideString; var pbCancel: WordBool): HResult;
begin
Result := S_OK;
if not Assigned (OnError) then System.Exit;
Result := OnError (Self, EventSource, ErrorCode, Source, Description, HelpFile, HelpContext, IDofInterfaceWithError, pbCancel);
end;
function TDTSPackageEvents.DoOnProgress(const EventSource: WideString; const ProgressDescription: WideString; PercentComplete: Integer; ProgressCountLow: Integer; ProgressCountHigh: Integer): HResult;
begin
Result := S_OK;
if not Assigned (OnProgress) then System.Exit;
Result := OnProgress (Self, EventSource, ProgressDescription, PercentComplete, ProgressCountLow, ProgressCountHigh);
end;
function TDTSPackageEvents.DoOnQueryCancel(const EventSource: WideString; var pbCancel: WordBool): HResult;
begin
Result := S_OK;
if not Assigned (OnQueryCancel) then System.Exit;
Result := OnQueryCancel (Self, EventSource, pbCancel);
end;
//SinkImplEnd//
procedure Register;
begin
//SinkRegisterStart//
RegisterComponents ('ActiveX', [TDTSPackageEvents]);
//SinkRegisterEnd//
end;
end.
/* DFM文件 */
object FrmMain: TFrmMain
Left = 192
Top = 156
BorderIcons = [biSystemMenu, biMinimize]
BorderStyle = bsSingle
Caption = 'DTS Demo App'
ClientHeight = 566
ClientWidth = 792
Color = clBtnFace
Font.Charset = ANSI_CHARSET
Font.Color = clWindowText
Font.Height = -15
Font.Name = '宋体'
Font.Style = []
OldCreateOrder = False
OnCreate = FormCreate
PixelsPerInch = 96
TextHeight = 15
object lbl1: TLabel
Left = 16
Top = 29
Width = 32
Height = 15
Caption = 'File'
end
object btnLoadFile: TButton
Left = 704
Top = 24
Width = 75
Height = 25
Caption = 'Load'
TabOrder = 0
OnClick = btnLoadFileClick
end
object edtFileName: TEdit
Left = 72
Top = 25
Width = 625
Height = 23
Enabled = False
TabOrder = 1
end
object btnExecute: TButton
Left = 704
Top = 56
Width = 75
Height = 25
Caption = 'Execute'
Enabled = False
TabOrder = 2
OnClick = btnExecuteClick
end
object mmoInfo: TMemo
Left = 16
Top = 64
Width = 673
Height = 481
ScrollBars = ssVertical
TabOrder = 3
end
object dlgOpen1: TOpenDialog
DefaultExt = '*.dts'
Filter = 'DTS包(*.dts)|*.dts|所有文件|*.*'
Left = 464
Top = 312
end
end
浙公网安备 33010602011771号