vb中记录导出为excel显示记录和循环问题

[twtiqfn]

我在窗件上放了datagrid控件，一共显示10行，但查询出来的记录有很多条，以下的代码存在的问题：datagrid显示的是哪十条，导出的excel表就是哪10条，我想把所有的记录从头到尾全导出来 应该怎么改进代码啊，谢谢
Private Sub Command1_Click()
Dim i As Long, j As Long
Dim xlsApp As Excel.Application
Dim xlsBook As Excel.Workbook
Dim xlsSheet As Excel.Worksheet
Set xlsApp = New Excel.Application
Set xlsApp = CreateObject("Excel.Application")
xlsApp.Visible = True
xlsApp.Workbooks.Add
xlsApp.Sheets("Sheet1").Select
DataGrid1.Row = 0
i = 1
Do While DataGrid1.Row >= 0
If i = DataGrid1.Row Then Exit Do
i = DataGrid1.Row
For j = 0 To DataGrid1.Columns.Count - 1
With xlsApp
.Cells(DataGrid1.Row + 1, j + 1) = DataGrid1.Columns(j).Text
End With
Next
DataGrid1.Row = DataGrid1.Row + 1
Loop

If xlsApp.ActiveWorkbook.Saved = False Then
xlsApp.ActiveWorkbook.SaveAs App.Path & "\mmm0.xls"
End If
xlsApp.Quit
Set xlsApp = Nothing

[c_cyd2008]

如要导出全部数据，你应从DataGrid的数据源入手，下面的例子假定你的DataGrid绑定的是Adodc控件：

Private Sub Command1_Click()
On Error GoTo Err_msg

fnDlg.ShowSave  '显示保存对话框
If fnDlg.FileName = "" Then
    Exit Sub
End If
Dim xlsfilename As String
xlsfilename = fnDlg.FileName '取得文件名

Dim xlsApp As New Excel.Application  '新建一个Execl应用程序对象
xlsApp.Visible = False
Dim xlsBook As Excel.Workbook
Set xlsBook = xlsApp.Workbooks.Add   '添加工作簿
Dim xlsSheet As Excel.Worksheet
Set xlsSheet = xlsBook.Sheets("sheet1")

Dim Row As Long, Col As Long
Row = 1
'把Adodc1.Recordset的内容全部写入Excel工作表
For Col = 0 To Adodc1.Recordset.Fields.Count - 1
        xlsSheet.Cells(Row, Col + 1) = Adodc1.Recordset.Fields(Col).Name
    Next
Row = 2
While Not Adodc1.Recordset.EOF           '写数据
    For Col = 0 To Adodc1.Recordset.Fields.Count - 1
        xlsSheet.Cells(Row, Col + 1) = Adodc1.Recordset(Col)
        If Adodc1.Recordset.Fields(Col).Type = adDate Then   '判断是否日期类型
            xlsSheet.Cells(Row, Col + 1).NumberFormatLocal = "yyyy-mm-dd"
        End If
    Next
    Adodc1.Recordset.MoveNext
    Row = Row + 1
Wend
xlsBook.SaveAs xlsfilename
MsgBox "成功导出：" & xlsfilename

Err_exit:
xlsBook.Close savechanges:=False
xlsApp.Quit          '记得关闭和退出

Set xlsApp = Nothing
Set xlsBook = Nothing
Set xlsSheet = Nothing
Exit Sub

Err_msg:
    MsgBox Err.Description
    Resume Err_exit
End Sub