Private Function Import_DTS(strPath As String) As Boolean
Dim oConnection As DTS.Connection
Dim oStep As DTS.Step
Dim oTask As DTS.Task
Dim oPackage As DTS.Package2
Dim oCustomTask As DTS.BulkInsertTask
On Error GoTo PackageError Import_DTS = True
'建立数据包
Set oPackage = New DTS.Package
oPackage.FailOnError = True
Set oConnection = oPackage.Connections.New("SQLOLEDB")
Set oStep = oPackage.Steps.New
Set oTask = oPackage.Tasks.New("DTSBulkInsertTask")
Set oCustomTask = oTask.CustomTask
'与数据库进行连接,为了清楚起见,这里我单独写了一个过程,即 SetConnections
'具体可以参考Private Sub SetConnections
SetConnections oPackage, oConnection
With oStep
.Name = "GenericPkgStep"
.ExecuteInMainThread = True
End With
'Customize the Task Object
With oCustomTask
.Name = "GenericPkgTask"
'文本文件的路径
.DataFile = strPath
.ConnectionID = 1
'注意目标表的写法
.DestinationTableName = strDBName & "..DriverName"
'以tab分隔列
.FieldTerminator = VBA.Chr(9)
'以换行回车分隔行
.RowTerminator = vbCrLf
End With
oStep.TaskName = oCustomTask.Name
'添加包
With oPackage
.Steps.Add oStep
.Tasks.Add oTask
.FailOnError = True
End With
'运行包
oPackage.Execute
'释放
Set oConnection = Nothing
Set oCustomTask = Nothing
Set oTask = Nothing
Set oStep = Nothing
oPackage.UnInitialize
Set oPackage = Nothing
Exit Function
'以下是出错处理
PackageError:
Dim strMsg As String
strMsg = "Package failed error: " & ErrorNumConv(Err.Number) & _
vbCrLf & Err.Description & vbCrLf & AccumStepErrors(oPackage)
MsgBox strMsg, vbExclamation, oPackage.Name
Set oConnection = Nothing
Set oCustomTask = Nothing
Set oTask = Nothing
Set oStep = Nothing
oPackage.UnInitialize
Set oPackage = Nothing
Import_DTS = False
End Function'以下是数据包与数据库的连接部分:
Private Sub SetConnections(oPackage As DTS.Package, oConnection As DTS.Connection)
With oConnection
.ConnectionProperties("Persist Security Info") = True
.ConnectionProperties("User ID") = strDBUser
.ConnectionProperties("Initial Catalog") = strDBName
.ConnectionProperties("Data Source") = strServerName
.Catalog = strDBName
.DataSource = sServerName
.UserID = strDBUser
.Password = strDBUserPsd
.ID = 1
.Reusable = True
.ConnectImmediate = False
.UseTrustedConnection = False
End With
oPackage.Connections.Add oConnection
Set oConnection = Nothing
End Sub'以下是出错处理
Private Function ErrorNumConv(ByVal lngErrNum As Long) As String If lngErrNum < 65536 And lngErrNum > -65536 Then
ErrorNumConv = "x" & Hex(lngErrNum) & ", " & CStr(lngErrNum)
Else
ErrorNumConv = "x" & Hex(lngErrNum) & ", x" & _
Hex(lngErrNum And -65536) & " + " & CStr(lngErrNum And 65535)
End IfEnd FunctionPrivate Function AccumStepErrors(ByRef oPackage As DTS.Package) As String
Dim oStep As DTS.Step
Dim strMessage As String
Dim lngErrNum As Long
Dim strDescr As String
Dim strSource As String '查找出错地
For Each oStep In oPackage.Steps
If oStep.ExecutionStatus = DTSStepExecStat_Completed Then
If oStep.ExecutionResult = DTSStepExecResult_Failure Then
'得到出错信息
oStep.GetExecutionErrorInfo lngErrNum, strSource, strDescr
strMessage = strMessage & vbCrLf & _
"Step " & oStep.Name & " failed, error: " & _
ErrorNumConv(lngErrNum) & vbCrLf & strDescr & vbCrLf
End If
End If
Next
AccumStepErrors = strMessageEnd Function
Dim oConnection As DTS.Connection
Dim oStep As DTS.Step
Dim oTask As DTS.Task
Dim oPackage As DTS.Package2
Dim oCustomTask As DTS.BulkInsertTask
On Error GoTo PackageError Import_DTS = True
'建立数据包
Set oPackage = New DTS.Package
oPackage.FailOnError = True
Set oConnection = oPackage.Connections.New("SQLOLEDB")
Set oStep = oPackage.Steps.New
Set oTask = oPackage.Tasks.New("DTSBulkInsertTask")
Set oCustomTask = oTask.CustomTask
'与数据库进行连接,为了清楚起见,这里我单独写了一个过程,即 SetConnections
'具体可以参考Private Sub SetConnections
SetConnections oPackage, oConnection
With oStep
.Name = "GenericPkgStep"
.ExecuteInMainThread = True
End With
'Customize the Task Object
With oCustomTask
.Name = "GenericPkgTask"
'文本文件的路径
.DataFile = strPath
.ConnectionID = 1
'注意目标表的写法
.DestinationTableName = strDBName & "..DriverName"
'以tab分隔列
.FieldTerminator = VBA.Chr(9)
'以换行回车分隔行
.RowTerminator = vbCrLf
End With
oStep.TaskName = oCustomTask.Name
'添加包
With oPackage
.Steps.Add oStep
.Tasks.Add oTask
.FailOnError = True
End With
'运行包
oPackage.Execute
'释放
Set oConnection = Nothing
Set oCustomTask = Nothing
Set oTask = Nothing
Set oStep = Nothing
oPackage.UnInitialize
Set oPackage = Nothing
Exit Function
'以下是出错处理
PackageError:
Dim strMsg As String
strMsg = "Package failed error: " & ErrorNumConv(Err.Number) & _
vbCrLf & Err.Description & vbCrLf & AccumStepErrors(oPackage)
MsgBox strMsg, vbExclamation, oPackage.Name
Set oConnection = Nothing
Set oCustomTask = Nothing
Set oTask = Nothing
Set oStep = Nothing
oPackage.UnInitialize
Set oPackage = Nothing
Import_DTS = False
End Function'以下是数据包与数据库的连接部分:
Private Sub SetConnections(oPackage As DTS.Package, oConnection As DTS.Connection)
With oConnection
.ConnectionProperties("Persist Security Info") = True
.ConnectionProperties("User ID") = strDBUser
.ConnectionProperties("Initial Catalog") = strDBName
.ConnectionProperties("Data Source") = strServerName
.Catalog = strDBName
.DataSource = sServerName
.UserID = strDBUser
.Password = strDBUserPsd
.ID = 1
.Reusable = True
.ConnectImmediate = False
.UseTrustedConnection = False
End With
oPackage.Connections.Add oConnection
Set oConnection = Nothing
End Sub'以下是出错处理
Private Function ErrorNumConv(ByVal lngErrNum As Long) As String If lngErrNum < 65536 And lngErrNum > -65536 Then
ErrorNumConv = "x" & Hex(lngErrNum) & ", " & CStr(lngErrNum)
Else
ErrorNumConv = "x" & Hex(lngErrNum) & ", x" & _
Hex(lngErrNum And -65536) & " + " & CStr(lngErrNum And 65535)
End IfEnd FunctionPrivate Function AccumStepErrors(ByRef oPackage As DTS.Package) As String
Dim oStep As DTS.Step
Dim strMessage As String
Dim lngErrNum As Long
Dim strDescr As String
Dim strSource As String '查找出错地
For Each oStep In oPackage.Steps
If oStep.ExecutionStatus = DTSStepExecStat_Completed Then
If oStep.ExecutionResult = DTSStepExecResult_Failure Then
'得到出错信息
oStep.GetExecutionErrorInfo lngErrNum, strSource, strDescr
strMessage = strMessage & vbCrLf & _
"Step " & oStep.Name & " failed, error: " & _
ErrorNumConv(lngErrNum) & vbCrLf & strDescr & vbCrLf
End If
End If
Next
AccumStepErrors = strMessageEnd Function
解决方案 »
免费领取超大流量手机卡,每月29元包185G流量+100分钟通话, 中国电信官方发货