Excel-SQL Server Import-Export using Visual Studio Tools for Office

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