vs2005兩個非常有用的函數_report2005如何创建公共函数-优快云博客

本文介绍了一种将数据集导出到Excel文件的方法，包括两种不同的实现方式：一种使用OLE DB连接直接写入数据，另一种利用Excel应用程序对象模型进行数据填充。

摘要生成于 C知道，由 DeepSeek-R1 满血版支持，前往体验 >

    'A 匯出到Excel
    Public Sub ExportExcel(ByVal MyDataSet As DataSet, ByVal SaveDl As SaveFileDialog)
        Dim MyTable As DataTable
        Dim MyOleDbCn As New OleDbConnection
        Dim MyOleDbCmd As New OleDbCommand
        Dim intRowsCnt, intColsCnt As Integer
        Dim strSql As String, strFlName As String
        MyTable = MyDataSet.Tables(0)

        'KillExcl("EXCEL")
        With SaveDl
            .Title = "請選擇要匯出的Excel文件名"
            .Filter = "Excel文件(*.xls)|*.xls"
            .FileName = ""
        End With
        If SaveDl.ShowDialog = DialogResult.OK Then
            If SaveDl.FileName <> "" Then
                strFlName = SaveDl.FileName()
            Else
                Exit Sub
            End If
        Else
            Exit Sub
        End If
        Try

            MyOleDbCn.ConnectionString = "Provider=Microsoft.Jet.OleDb.4.0;" & _
            "Data Source=" & strFlName & ";" & _
            "Extended ProPerties=""Excel 8.0;HDR=Yes;"""
            MyOleDbCn.Open()
            MyOleDbCmd.Connection = MyOleDbCn
            MyOleDbCmd.CommandType = CommandType.Text

            '第一行插入列標題
            strSql = "CREATE TABLE sheet1("
            For intColsCnt = 0 To MyTable.Columns.Count - 1
                If intColsCnt <> MyTable.Columns.Count - 1 Then
                    strSql = strSql & MyTable.Columns(intColsCnt).Caption & " text,"
                Else
                    strSql = strSql & MyTable.Columns(intColsCnt).Caption & " text)"
                End If
            Next
            MyOleDbCmd.CommandText = strSql
            MyOleDbCmd.ExecuteNonQuery()

            '插入各行
            For intRowsCnt = 0 To MyTable.Rows.Count - 1
                strSql = "INSERT INTO sheet1 VALUES('"
                For intColsCnt = 0 To MyTable.Columns.Count - 1
                    If intColsCnt <> MyTable.Columns.Count - 1 Then
                        strSql = strSql & MyTable.Rows(intRowsCnt).Item(intColsCnt) & "','"
                    Else
                        strSql = strSql & MyTable.Rows(intRowsCnt).Item(intColsCnt) & "')"
                    End If
                Next
                MyOleDbCmd.CommandText = strSql
                MyOleDbCmd.ExecuteNonQuery()
            Next
            MessageBox.Show("數據已經成功導入EXCEL文件" & strFlName, "數據導出", MessageBoxButtons.OK, MessageBoxIcon.Information)

        Catch ex As Exception
            MsgBox("錯誤信息 :" & ex.Message & vbCrLf & vbCrLf & _
            "引發事件 :" & ex.TargetSite.ToString, MsgBoxStyle.OkOnly + MsgBoxStyle.Information, "錯誤來源 :" & ex.Source)
            Exit Sub
        Finally
            MyOleDbCmd.Dispose()
            MyOleDbCn.Close()
            MyOleDbCn.Dispose()

End Try

End Sub

'B匯出到Excel

    Public Sub ToExcel(ByVal MyDataSet As DataSet, ByVal SaveDl As SaveFileDialog)
        Dim MyTable As DataTable
        Dim intRowsCnt, intColsCnt As Integer
        MyTable = MyDataSet.Tables(0)

        Dim xlApp As Excel.Application
        Dim xlBook As Excel.Workbook
        Dim xlSheet As Excel.Worksheet
        Dim sOutFile As String
        Dim sObjName As String
        Dim strSource, strDestination As String
        Dim Intnum As Integer, iTim As Integer, sDir As String

sOutFile = IIf(Microsoft.VisualBasic.Right(Application.StartupPath, 1) = "/", Application.StartupPath, Application.StartupPath & "/")
strSource = sOutFile & "Samples.xls"

        iTim = Microsoft.VisualBasic.Left(Timer, 4)
        sObjName = CStr("Report") & CStr(iTim) & ".xls"
        'sOutFile = sOutFile & sObjName
        sDir = "C:/temp"
        If Len(Dir(sDir, vbDirectory)) <= 0 Then
            MkDir(sDir)
        End If
        sDir = "C:/temp/whcn"
        If Len(Dir(sDir, vbDirectory)) <= 0 Then
            MkDir(sDir)
        End If
        sDir = "C:/temp/whcn/"
        strDestination = sDir & sObjName
        If Len(Dir(strDestination, vbDirectory)) > 0 Then
            Kill(strDestination)
        End If
        FileCopy(strSource, strDestination)
        xlApp = New Excel.Application
        xlBook = xlApp.Workbooks.Open(strDestination)
        xlSheet = xlBook.Worksheets(1)
        xlSheet.Activate()

        '第一行插入列標題
        For intColsCnt = 0 To MyTable.Columns.Count - 1
            xlSheet.Cells(1, intColsCnt + 1).Value = MyTable.Columns(intColsCnt).Caption
        Next
        '插入各行
        For intRowsCnt = 0 To MyTable.Rows.Count - 1

            For intColsCnt = 0 To MyTable.Columns.Count - 1
                xlSheet.Cells(intRowsCnt + 2, intColsCnt + 1).Value = MyTable.Rows(intRowsCnt).Item(intColsCnt)
            Next

        Next
        xlApp.Range("a1").Select()
        xlBook.Save()

xlApp.Visible = True

xlSheet = Nothing
End Sub