Import and Export Data Between Excel and SQL Server Using VSTO

Public Function CreateQueryTable(ByVal connectionString As String, _
 ByVal commandText As String, ByVal target As Excel.Range) As Integer
 On Error Resume Next
 Dim ws As Excel.Worksheet = target.Worksheet
 If Not target.ListObject Is Nothing Then
 ws.ShowAllData() ' Excel has a bug of the filtered ListObject deletion
 target.ListObject.Delete()
 End If
 ' Excel QueryTable requires "OLEDB;" at the start of the connection string
 connectionString = "OLEDB;" & connectionString
 ' Connection string of QueryTable has length limit
 Dim source(1) As Object
 source(0) = Mid(connectionString, 1, 200)
 source(1) = Mid(connectionString, 201)
 Dim lo As Excel.ListObject = _
 ws.ListObjects.Add(SourceType:=0, source:=source, Destination:=target.Cells(1, 1))
 ' lo.DisplayName = ws.Name & "_Table"
 With lo.QueryTable
 Select Case UCase(Left(Trim(commandText), 4))
 Case "EXEC", "SELE"
 .CommandType = Excel.XlCmdType.xlCmdSql
 Case Else
 .CommandType = Excel.XlCmdType.xlCmdTable
 End Select
 .CommandText = commandText
 .SavePassword = True
 '.RowNumbers = True
 .PreserveColumnInfo = True
 .PreserveFormatting = True
 .AdjustColumnWidth = False
 .Refresh(BackgroundQuery:=False)
 End With
 CreateQueryTable = 0
End Function

Public Function ImportSQLtoRange(ByVal connectionString As String, _
 ByVal commandText As String, ByVal target As Excel.Range) As Integer
 Try
 Dim ws As Excel.Worksheet = target.Worksheet
 Dim arr(0, 0) As Object
 ExecuteOleDbDataReader(connectionString, commandText, AddressOf OleDbDataReaderToArray, arr)
 Dim rowCount As Long = arr.GetLength(1)
 Dim colCount As Integer = arr.GetLength(0)
 Dim r As Excel.Range ' The complete target range with arr dimensions
 With ws
 r = .Application.Range( _
 .Cells(target.Row, target.Column), _
 .Cells(target.Row + rowCount - 1, target.Column + colCount - 1) _
 )
 End With
 ' This method works very fast
 r.Value = ws.Application.WorksheetFunction.Transpose(arr)
 ws.ListObjects.Add(Excel.XlListObjectSourceType.xlSrcRange, r, , Excel.XlYesNoGuess.xlYes)
 ImportSQLtoRange = 0
 Catch ex As Exception
 ImportSQLtoRange = 1
 LastErrorMessage = ex.Message
 End Try
End Function

Public Function ExportRangeToDatabase(ByVal sourceRange As Excel.Range, _
 ByVal connectionString As String, ByVal tableName As String, _
 Optional ByVal beforeSQL As String = "", _
 Optional ByVal afterSQL As String = "") As Integer
 Dim commandText As String = "SELECT * FROM " & tableName
 Dim cmd As OleDbCommand
 Try
 Using connection As New OleDbConnection(connectionString)
 If beforeSQL > "" Then
 cmd = New OleDbCommand(beforeSQL, connection)
 Try
 cmd.CommandType = CommandType.Text
 connection.Open()
 cmd.ExecuteNonQuery()
 Finally
 If Not cmd Is Nothing Then : cmd.Dispose() : End If
 End Try
 End If
 Dim dataAdapter As New OleDbDataAdapter(commandText, connection)
 Try
 Dim dataTable As New DataTable
 Try
 dataAdapter.Fill(dataTable)
 Dim builder As OleDbCommandBuilder = _
 New OleDbCommandBuilder(dataAdapter)
 Try
 dataAdapter.InsertCommand = builder.GetInsertCommand()
 ' Column mappings
 Dim rangeFields(100) As Integer
 Dim tableFields(100) As Integer
 Dim tableFieldTypes(100) As String
 Dim exportFieldsCount As Integer
 exportFieldsCount = 0
 Dim col As Integer
 Dim index As Integer
 ' Set the range before .Match call!
 Dim rangeHeaders As Excel.Range = sourceRange.Rows(1)
 Dim cellFormat As String
 For col = 0 To dataTable.Columns.Count - 1
 index = sourceRange.Application.Match( _
 dataTable.Columns(col).ColumnName, rangeHeaders, 0)
 If index > 0 Then
 exportFieldsCount = exportFieldsCount + 1
 rangeFields(exportFieldsCount) = index
 tableFields(exportFieldsCount) = col
 tableFieldTypes(exportFieldsCount) = _
 dataTable.Columns(col).DataType.ToString
 ' Transformation for the Time datatype
 If tableFieldTypes(exportFieldsCount) = _
 "System.String" Then
 cellFormat = _
 sourceRange.Cells(2, index).NumberFormat
 If cellFormat.Contains(":") Then
 tableFieldTypes(exportFieldsCount) = "Time"
 End If
 End If
 End If
 Next
 If exportFieldsCount = 0 Then
 ExportRangeToDatabase = 1
 Exit Function
 End If
 ' Fast read of Excel range values to an array
 ' for further fast work with the array
 Dim arr As Object
 arr = sourceRange.Value
 ' The range data transfer to the dataTable
 Dim row As Long
 Dim rowCount As Long
 rowCount = UBound(arr, 1)
 Dim value As Object
 Dim dataRow As DataRow
 For row = 2 To rowCount
 dataRow = dataTable.NewRow()
 For col = 1 To exportFieldsCount
 value = arr(row, rangeFields(col))
 If value Is Nothing Then
 ElseIf tableFieldTypes(col) = "System.DateTime" Then
 If value.GetType.ToString() = _
 "System.Double" Then
 dataRow(tableFields(col)) = _
 DateTime.FromOADate(value)
 Else
 dataRow(tableFields(col)) = value
 End If
 ElseIf tableFieldTypes(col) = "Time" Then
 If value.GetType.ToString() = _
 "System.Double" Then
 dataRow(tableFields(col)) = _
 DateTime.FromOADate(value).ToString("HH:mm:ss")
 Else
 dataRow(tableFields(col)) = _
 DateTime.Parse(value).ToString("HH:mm:ss")
 End If
 Else
 dataRow(tableFields(col)) = value
 End If
 Next
 dataTable.Rows.Add(dataRow)
 Next
 dataAdapter.Update(dataTable)
 Finally
 builder.Dispose()
 End Try
 Finally
 dataTable.Dispose()
 End Try
 Finally
 dataAdapter.Dispose()
 End Try
 If afterSQL > "" Then
 cmd = New OleDbCommand(afterSQL, connection)
 Try
 cmd.CommandType = CommandType.Text
 cmd.ExecuteNonQuery()
 Finally
 If Not cmd Is Nothing Then : cmd.Dispose() : End If
 End Try
 End If
 End Using
 ExportRangeToDatabase = 0
 LastErrorMessage = Nothing
 Catch sqlExc As OleDbException
 ExportRangeToDatabase = 1
 LastErrorMessage = sqlExc.Message
 Catch ex As Exception
 ExportRangeToDatabase = 1
 LastErrorMessage = ex.Message
 End Try
End Function

Delegate Sub ExecuteOleDbDataReaderDelegate(ByVal dataReader As OleDbDataReader, _
 ByRef context As Object)
Public Function ExecuteOleDbDataReader(ByVal connectionString As String, _
 ByVal commandText As String, _
 ByVal processor As ExecuteOleDbDataReaderDelegate, _
 ByRef context As Object) As Boolean
 Try
 Using connection As New OleDbConnection(connectionString)
 Dim cmd As New OleDbCommand(commandText, connection)
 Try
 cmd.CommandType = CommandType.Text
 connection.Open()
 Using dataReader As OleDbDataReader = _
 cmd.ExecuteReader(CommandBehavior.CloseConnection)
 processor(dataReader, context)
 End Using
 Finally
 If Not cmd Is Nothing Then : cmd.Dispose() : End If
 End Try
 Return True
 End Using
 Catch sqlExc As OleDbException
 MsgBox(sqlExc.Message, MsgBoxStyle.Exclamation)
 Return False
 Catch ex As Exception
 MsgBox(ex.Message, MsgBoxStyle.Exclamation)
 Return False
 End Try
End Function

Public Sub OleDbDataReaderToArray(ByVal dataReader As OleDbDataReader, _
 ByRef context As Object)
 Dim row As Long = -1
 Dim colCount As Integer = dataReader.FieldCount
 Dim rowCapacity As Long = 1000
 ReDim context(colCount - 1, rowCapacity - 1)
 row = row + 1
 For col As Integer = 0 To colCount - 1
 context(col, row) = dataReader.GetName(col)
 Next
 Do While dataReader.Read
 row = row + 1
 If row = rowCapacity Then
 rowCapacity = rowCapacity + 1000
 ReDim Preserve context(colCount - 1, rowCapacity - 1)
 End If
 For col As Integer = 0 To colCount - 1
 context(col, row) = dataReader(col).ToString
 Next
 Loop
 ReDim Preserve context(colCount - 1, row)
End Sub

Public Function GetConnectionString( _
 ByVal server As String, _
 ByVal database As String, _
 ByVal username As String, _
 ByVal password As String, _
 Optional ByVal extended As String = "") As String
 If (extended = "") And UCase(server).Contains(".NET") Then
 extended = "Extended Properties=""Encrypt=True;TrustServerCertificate=True"";"
 End If
 If username = "" Then
 Return String.Format("Provider=SQLOLEDB.1;Integrated Security=SSPI{2};" _
 & "Persist Security Info=True;" _
 & "Data Source={0};Use Procedure for Prepare=1;Auto Translate=True;" _
 & "Packet Size=4096;Initial Catalog={1}", _
 server, database, extended)
 Else
 Return String.Format("Provider=SQLOLEDB.1;Password={3};User ID={2};{4}" _
 & "Persist Security Info=True;" _
 & "Data Source={0};Use Procedure for Prepare=1;Auto Translate=True;" _
 & "Packet Size=4096;Initial Catalog={1}", _
 server, database, username, password, extended)
 End If
End Function

Public DataAdapters As New SortedList(Of String, OleDbDataAdapter)
Function ImportToolsListObject( _
 ByVal connectionString As String, _
 ByVal commandText As String, _
 ByVal sh As WorksheetBase, _
 ByVal target As Excel.Range) As Integer
 Dim listObjectName As String = _
 String.Format("DataTable_{0}", DataAdapters.Count + 1)
 Try
 Using connection As New OleDbConnection(connectionString)
 Dim dataTable As New DataTable
 Dim dataAdapter As New OleDbDataAdapter(commandText, connection)
 dataAdapter.Fill(dataTable)
 Dim builder As OleDbCommandBuilder = New OleDbCommandBuilder(dataAdapter)
 With dataAdapter
 .InsertCommand = builder.GetInsertCommand()
 .UpdateCommand = builder.GetUpdateCommand()
 .DeleteCommand = builder.GetDeleteCommand()
 End With
 DataAdapters.Add(listObjectName, dataAdapter)
 With sh.Controls.AddListObject(target, listObjectName)
 .AutoSetDataBoundColumnHeaders = True
 .DataSource = dataTable
 End With
 ' Don't call Dispose for these objects:
 ' builder.Dispose()
 ' dataAdapter.Dispose()
 ' dataTable.Dispose()
 End Using
 ImportToolsListObject = 0
 LastErrorMessage = Nothing
 Catch ex As Exception
 ImportToolsListObject = 1
 LastErrorMessage = ex.Message
 End Try
End Function

Function ExportToolsListObject(ByVal connectionString As String, _
 ByVal lo As Microsoft.Office.Tools.Excel.ListObject) As Integer
 If DataAdapters.Count = 0 Then
 ExportToolsListObject = 1
 LastErrorMessage = "There are no DataAdapters"
 Exit Function
 End If
 Try
 Dim dataTable As DataTable = lo.DataSource
 Using connection As New OleDbConnection(connectionString)
 With DataAdapters(lo.DisplayName)
 .SelectCommand.Connection = connection
 .InsertCommand.Connection = connection
 .UpdateCommand.Connection = connection
 .DeleteCommand.Connection = connection
 .Update(dataTable)
 dataTable.Clear()
 .Fill(dataTable)
 End With
 End Using
 ExportToolsListObject = 0
 LastErrorMessage = Nothing
 Catch ex As Exception
 ExportToolsListObject = 1
 LastErrorMessage = ex.Message
 End Try
End Function

Function RefreshToolsListObject(ByVal connectionString As String, _
 ByVal lo As Microsoft.Office.Tools.Excel.ListObject) As Integer
 If DataAdapters.Count = 0 Then
 RefreshToolsListObject = 1
 LastErrorMessage = "There are no DataAdapters"
 Exit Function
 End If
 Try
 Dim dataTable As DataTable = lo.DataSource
 dataTable.Clear()
 Using connection As New OleDbConnection(TestConnectionString)
 With DataAdapters(lo.DisplayName)
 .SelectCommand.Connection = connection
 .Fill(dataTable)
 End With
 End Using
 RefreshToolsListObject = 0
 LastErrorMessage = Nothing
 Catch ex As Exception
 RefreshToolsListObject = 1
 LastErrorMessage = ex.Message
 End Try
End Function

Contents

• Introduction
• Import-Export Approaches
  • Using QueryTable Object
  • Using Range Object
  • Using VSTO ListObject
• About the Solution
• Developer's Notes
• Excel Configuration
• Using Native Excel Objects
• Using VSTO Objects
• Conclusion
• Download
• See Also

Related Articles

• Import-Export Using VBA
• Import-Export using Add-Ins