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