vb查询记录导出到EXCEL

twtiqfn 2010-11-24 02:48:10

我想把datagrid显示出来的记录导出到EXCEL表中，我在网上看到了一段导出代码：如下所示
我想加一个“导出”按钮，只要点一下，就能导出到excel中,也不知道代码有问题没有，如果没问题，请问大家我该怎么调用呢
Public Sub ExportToExcel(AdoRecordSet As ADODB.Recordset)
On Error GoTo Excel_Err
Dim Excel_Dsn As String
Dim Excel_Conn As New ADODB.Connection
Dim Excel_Adodc As New ADODB.Recordset
Dim mySql As String
Dim i, j, TmpField, FileName
Rem 得到文件名
For i = 0 To 100
If Len(i) = 1 Then
FileName = "C:\Query_0" & i
Else
FileName = "C:\Query_" & i
End If
If Dir(FileName & ".xls", vbHidden) = "" Then
Exit For
End If
Next
FileName = FileName & ".xls"
Excel_Dsn = "DRIVER={Microsoft Excel Driver (*.xls)};DSN='';FIRSTROWHASNAMES=1;READONLY=FALSE;CREATE_DB=""" & FileName & """;DBQ=" & FileName
Excel_Conn.Open Excel_Dsn
With AdoRecordSet
If Not (.EOF And .BOF) Then
mySql = "Create Table [Query] ("
For i = 0 To .Fields.Count - 1
TmpField = FieldType(.Fields(i).Type)
If TmpField = "char" Or TmpField = "varchar" Or TmpField = "nchar" Or TmpField = "nvarchar" Or TmpField = "varbinary" Then
If .Fields(i).DefinedSize >= 256 Then
mySql = mySql & Trim(.Fields(i).Name) & " text,"
Else
mySql = mySql & Trim(.Fields(i).Name) & " " & FieldType(.Fields(i).Type) & "(" & .Fields(i).DefinedSize & ")" & ","
End If
ElseIf TmpField <> "image" Then
mySql = mySql & Trim(.Fields(i).Name) & " " & FieldType(.Fields(i).Type) & ","
End If
Next
mySql = Left(Trim(mySql), Len(Trim(mySql)) - 1)
mySql = mySql & ")"
Rem 创建表名
Excel_Adodc.Open mySql, Excel_Dsn, adOpenDynamic, adLockPessimistic
Rem 插入数据
For i = 0 To .RecordCount - 1
mySql = "Insert into [Query] Values("
For j = 0 To .Fields.Count - 1
TmpField = FieldType(.Fields(j).Type)
Rem Image 不作保存
If TmpField <> "image" Then
If IsNull(.Fields(j).Value) Then
mySql = mySql & "NULL,"
Else
mySql = mySql & "'" & .Fields(j).Value & "',"
End If
End If
Next
mySql = Left(Trim(mySql), Len(Trim(mySql)) - 1)
mySql = mySql & ")"
Excel_Adodc.Open mySql, Excel_Dsn, adOpenDynamic, adLockPessimistic
.MoveNext
Next
MsgBox "系统提示:" & Chr(13) & " 已经将文件保存到 [ " & FileName & " ]", 64, "系统信息:"
End If
End With
Excel_Conn.Close
Set Excel_Conn = Nothing
Set Excel_Adodc = Nothing
Exit Sub
Excel_Err:
MsgBox "发生错误:" & Err.Description & Chr(13) & "错误代码:" & Err.Number, 64, "系统信息:"
End Sub

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

End Sub

...全文