关于datagrid中内容输出到word或excel的问题

Question

如何将datagrid中内容输出到word或excel的问题，我是菜鸟，我想要具体的源码，各位大虾谢谢了！

Answer 1

好啊，要代码是吧，写给你啊，看得懂看不懂那就看你自己咯Option ExplicitPublic Rs As New ADODB.Recordset
Public Conn As New ADODB.Connection
Public strConn As StringPrivate Sub Command1_Click()
    ExporToExcel strConn
End SubPrivate Sub Form_Load()    strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\Test.mdb;Persist Security Info=False"
    Conn.CursorLocation = adUseClient
    Conn.Open strConn
    If Rs.State <> adStateClosed Then Rs.Close
    Rs.Open "Select * from jobs", Conn, adOpenStatic, adLockOptimistic
    Set DataGrid1.DataSource = Rs
End SubPublic Function ExporToExcel(strOpen As String)
    Dim Rs_Data As New ADODB.Recordset
    Dim Irowcount As Integer
    Dim Icolcount As Integer    Dim xlApp As New Excel.Application
    Dim xlBook As Excel.Workbook
    Dim xlSheet As Excel.Worksheet
    Dim xlQuery As Excel.QueryTable    With Rs_Data
        If Rs_Data.State <> adStateClosed Then Rs_Data.Close
        .Open "Select * from jobs", Conn, adOpenStatic, adLockOptimistic
    End With
    With Rs_Data
        If .RecordCount < 1 Then
            MsgBox ("没有记录!")
            Exit Function
        End If        Irowcount = .RecordCount        Icolcount = .Fields.Count
    End With    Set xlApp = CreateObject("Excel.Application")
    Set xlBook = Nothing
    Set xlSheet = Nothing
    Set xlBook = xlApp.Workbooks().Add
    Set xlSheet = xlBook.Worksheets("sheet1")
    xlApp.Visible = True    Set xlQuery = xlSheet.QueryTables.Add(Rs_Data, xlSheet.Range("a1"))    With xlQuery
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = True
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
    End With    xlQuery.FieldNames = True
    xlQuery.Refresh    xlApp.Application.Visible = True
    Set xlApp = Nothing
    Set xlBook = Nothing
    Set xlSheet = NothingEnd Function

Answer 2

我有VB6.0的转换为EXCEL的。QQ：314638680

Answer 3

我刚好做了一个更简单的：
Private Sub cmdExcel_Click()
    Dim intPtr As Integer
    Dim intRowCount As Long
    Dim intColCount As Long
    
    Dim ExcelAppx As excel.Application
    Dim ExcelBookX As excel.Workbook
    Dim ExcelSheetX As excel.Worksheet
    Dim ExcelQueryX As excel.QueryTable
    
    With rsErpConn
        If rsErpConn.RecordCount < 1 Then
            Call MsgBox("没有记录！", vbExclamation, "错误")
            Exit Sub
        End If
        '记录总数
        intRowCount = .RecordCount
        intColCount = .Fields.Count
    End With
    
    On Error GoTo ExcelERR
    '建立Excel应用程序
    Set ExcelAppx = CreateObject("Excel.Application")
    '建立WorkBook
    Set ExcelBookX = ExcelAppx.Workbooks().Add(App.Path & "\制单目录.xlt")
    '建立表格sheet
    Set ExcelSheetX = ExcelBookX.Worksheets("制单目录")
    ExcelAppx.Visible = True
    '查询表格，填充EXCEL表格
    '从A3处向下开始填充
    rsErpConn.MoveFirst
    For intPtr = 1 To rsErpConn.RecordCount
        ExcelSheetX.Range("A3").CopyFromRecordset rsErpConn
        rsErpConn.MoveNext
    Next intPtr
    
    ExcelAppx.Application.Visible = True
    ExcelSheetX.PrintPreview
    ExcelAppx.DisplayAlerts = False
    ExcelAppx.Quit
    Set ExcelAppx = Nothing
    Set ExcelBookX = Nothing
    Set ExcelSheetX = Nothing
    
    Exit Sub
    
ExcelERR:
    If rsErpConn.BOF = False And rsErpConn.EOF = False Then
        MsgBox "填充Excel表格错误，" & Err.Description, vbCritical, "出错"
    End If
    If Not ExcelAppx Is Nothing Then ExcelAppx.Quit
    
End Sub