怎样用查询到的记录集生成Excel表格?????

adaoke_captain 2005-09-01 10:03:49
我想把查询到的记录集生成Excel表格,请问在VB里该怎么做????
...全文
228 7 打赏 收藏 转发到动态 举报
写回复
用AI写文章
7 条回复
切换为时间正序
请发表友善的回复…
发表回复
adaoke_captain 2005-09-05
  • 打赏
  • 举报
回复
谢谢各位我先试试
jfyhdcm 2005-09-02
  • 打赏
  • 举报
回复
up
yorkness 2005-09-02
  • 打赏
  • 举报
回复
S_Out = "select * from md"

Call ExporToExcel(S_Out, connstr) 'connstr为连接字符串

Public Function ExporToExcel(strOpen As String, Connstr As String)
'*********************************************************
'* 名称:ExporToExcel
'* 功能:导出数据到EXCEL
'* 用法:ExporToExcel(sql查询字符串)
'*********************************************************
'Dim cn As New ADODB.Connection
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
' cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source ='" + App.Path & "\info.mdb" + "' ;Persist Security Info=False"
With Rs_Data
If .State = adStateOpen Then
.Close
End If
.ActiveConnection = Connection
.CursorLocation = adUseClient
.CursorType = adOpenStatic
.LockType = adLockReadOnly
.Source = strOpen
.Open
End With
' Rs_Data.Open strOpen, Cn, adOpenStatic, adLockReadOnly
With Rs_Data
' .MoveFirst
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
'添加查询语句,导入EXCEL数据
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

With xlSheet
.Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Name = "黑体"
'设标题为黑体字
.Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Bold = True
'标题字体加粗
.Range(.Cells(1, 1), .Cells(Irowcount + 1, Icolcount)).Borders.LineStyle = xlContinuous
'设表格边框样式
End With

'With xlSheet.PageSetup
' .LeftHeader = "" & Chr(10) & "&""楷体_GB2312,常规""&10公司名称:无锡巨丰漆包线厂" ' & Gsmc
' .CenterHeader = "&""楷体_GB2312,常规""发货情况表&""宋体,常规""" & Chr(10) & "&""楷体_GB2312,常规""&10日 期:"
' .RightHeader = "" & Chr(10) & "&""楷体_GB2312,常规""&10单位:"
' .LeftFooter = "&""楷体_GB2312,常规""&10制表人:"
' .CenterFooter = "&""楷体_GB2312,常规""&10制表日期:"
' .RightFooter = "&""楷体_GB2312,常规""&10第&P页 共&N页"
'End With


xlApp.Application.Visible = True
Set xlApp = Nothing '"交还控制给Excel
Set xlBook = Nothing
Set xlSheet = Nothing

'Dim P As Integer, P1 As Integer
'Dim Str_Temp As String

'Str_Temp = FileName
'P = 0
'P1 = 0
'For i = 1 To Len(FileName)
' P1 = InStr(1, Mid(Str_Temp, 1, (Len(FileName) - P)), "\")
' If P1 > 0 Then
' P = P1 + P
' Str_Temp = Right(Str_Temp, (Len(Str_Temp) - P1))
' Else
' Exit For
' End If
'Next

'If P > 0 Then ChDir Left(FileName, (P - 1))
'ActiveWorkbook.SaveAs FileName:=FileName, FileFormat:=xlNormal _
' , Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
' CreateBackup:=False

End Function
jfyhdcm 2005-09-02
  • 打赏
  • 举报
回复
以上代码中,是接收的查询串,楼主问的是接收记录集,我的代码如下:分享:
Public Function rstoexcel(rstable As ADODB.Recordset, cexcelname As String) As Boolean
On Error GoTo gherr
Dim icol As Integer '列数,用于保存字段个数
Dim ijlts As Long '记录条数
Dim yesorno As Long '确认或是取消的标志

Dim AppExcel As Excel.Application '定义
Dim BookExcel As Excel.Workbook '工作簿对象
Dim sheetexcel As Excel.Worksheet '工作表

'如果没传过来文件名则返回
If Len(cexcelname) = 0 Then
Exit Function
End If

With rstable
If .RecordCount < 1 Then
MsgBox ("没有记录可供导出,该操作已经取消!")
rstoexcel = False
Exit Function
Else
icol = .Fields.Count '求字段数
ijlts = .RecordCount '求记录数
End If
End With

If Dir$(cexcelname) <> "" Then
yesorno = MsgBox("这个文件名已经存在,是否选择覆盖?如果该文件正处于打开状态由不能写入,请首先关闭该文件!", vbYesNo + vbDefaultButton2 + vbQuestion)
Else
yesorno = 6 '如果文件名并不存存,则置标志为可导出
End If

If yesorno <> 6 Then
rstoexcel = False
Exit Function
End If

Set AppExcel = New Excel.Application '创建excel对象
Set BookExcel = AppExcel.Workbooks.Add '添加工作簿
Set sheetexcel = BookExcel.Worksheets("sheet1") '添加工作表
For icol = 0 To rstable.Fields.Count - 1
AppExcel.Worksheets(1).Cells(1, icol + 1).Value = rstable.Fields(icol).Name
Next
AppExcel.Worksheets(1).Range("A2").CopyFromRecordset rstable

With sheetexcel
'.Range(.Cells(1, 1), .Cells(1, icol)).Font.Name = "黑体"
'设标题为黑体字
.Range(.Cells(1, 1), .Cells(1, icol)).Font.Bold = False '不加粗
'标题字体加粗
.Range(.Cells(1, 1), .Cells(ijlts + 1, icol)).Borders.LineStyle = xlContinuous '如果第一行不显示字段,则不用加一
'设表格边框样式
End With

BookExcel.SaveAs (cexcelname)

'MsgBox ("该文件名已经存在,不能导出,否则将覆盖,请给出新的名称")
'rstoexcel = False
AppExcel.Quit
Set sheetexcel = Nothing
Set BookExcel = Nothing
Set AppExcel = Nothing
rstoexcel = True
Exit Function
gherr:
'MsgBox "电子表格导出失败,请检查该文件是否处理打开状态,错误信息如下:" & Chr(13) & Err.Number & "," & Err.Description
'MsgBox "由于未知原因,导出失败!", vbQuestion
rstoexcel = False
End Function
ezstu 2005-09-02
  • 打赏
  • 举报
回复
TO yorkness(机器猫)
这是你的原创?还是???????
huntercsl 2005-09-02
  • 打赏
  • 举报
回复
学习跟进
SetMeFree 2005-09-01
  • 打赏
  • 举报
回复
建议使用VBA

7,759

社区成员

发帖
与我相关
我的任务
社区描述
VB 基础类
社区管理员
  • VB基础类社区
加入社区
  • 近7日
  • 近30日
  • 至今
社区公告
暂无公告

试试用AI创作助手写篇文章吧