如何用VB代码将ms sql server 2000 中一个数据库中一个表导出成Excel文件(在线等待)

zhstar 2003-03-29 02:05:05
如题,请给出源代码
...全文
245 点赞 收藏 7
写回复
7 条回复
切换为时间正序
当前发帖距今超过3年,不再开放新的回复
发表回复
Javaxhb 2003-04-02
ExporToExcel strOpen
回复
Javaxhb 2003-04-02
strOpen="select * from table"
ExportToExcel

Public Function ExporToExcel(strOpen As String)
Dim obj As Object
Dim rs 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
Set rs = New ADODB.Recordset
rs.CursorLocation = adUseClient
rs.LockType = adLockReadOnly
rs.Open strOpen, MProperty.CnnString

If rs.EOF Then
MsgBox ("没有记录!")
Exit Function
End If

Irowcount = rs.RecordCount
Icolcount = rs.Fields.Count

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, 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公司名称:"
.CenterHeader = "&""楷体_GB2312,常规""XXXXXXXXXX表&""宋体,常规""" & 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
End Function



回复
xayzmb 2003-04-01
这是类中的一个函数
其中有用到别处的数据
是以属性方式传进来的
基本操做过程应该能看明白。
回复
xayzmb 2003-04-01
Private Function PuTongChaXun(pgb As ProgressBar, labTiShi As Label, strWhere As String) As Boolean
On Error GoTo err1
'将普通查询结果传送到Excel
Dim clsX As Long '记录列数
Dim SQL As String
Dim i As Long
Dim j As Long
'检查输入数据
If Len(strWhere) < 1 Then
Exit Function
Else
'生成查询语句
SQL = strWhere
End If

'生成Excel对象
Set exl = New excel.Application
'生成Excel空工作表
exl.Workbooks.Add
'连接数据库
Data.openCon
If rs.State <> 0 Then
rs.Close
End If
'打开查询记录集合
rs.Open SQL, Data.Con, adOpenStatic
'检查集合数量
If rs.EOF = True Then
rs.Close
exl.DisplayAlerts = False
exl.Quit
exl.DisplayAlerts = True
Set exl = Nothing
Exit Function
Else
Dim rsF As Field
rs.MoveLast
'保存记录集总数
clsNum = rs.RecordCount
'取得记录列数
For Each rsF In rs.Fields
clsX = clsX + 1
Next
'设置数组变量
ReDim clsTable(clsX, clsNum)
'将表头写入数组
For i = 0 To clsX - 1
clsTable(i, 0) = rs.Fields(i).Name
Next

'重置进度条状态
pgb.Min = 0 '进度条最小值
pgb.Max = clsNum + 1 '进度条最大值
pgb.Value = 0 '进度条状态值
rs.MoveFirst

'向数组写入数据
For i = 1 To clsNum
DoEvents
If exitF = True Then
'检查是否取消
exl.DisplayAlerts = False
exl.Quit
exl.DisplayAlerts = True
Set exl = Nothing
exitF = False
PuTongChaXun = False
Exit Function
Else
For j = 0 To clsX - 1
'将数据写入变量数组
clsTable(j, i) = rs.Fields(j) & ""
Next
'显示写入进度
pgb.Value = i
'移动记录
rs.MoveNext
End If
Next
'关闭数据集合
rs.Close
'关闭数据连接
Data.closeCon

'重置进度条
pgb.Value = 0

'将数据写入Excel表
For i = 0 To clsNum
DoEvents
If exitF = True Then
'检查是否取消
exl.DisplayAlerts = False
exl.Quit
exl.DisplayAlerts = True
Set exl = Nothing
exitF = False
PuTongChaXun = False
Exit Function
Else
j = 0
For j = 0 To clsX - 1
'将数据写入表格
exl.Cells(i + 1, j + 1).Select
If IsDate(clsTable(j, i)) = True Then
exl.Selection.NumberFormatLocal = "@"
Else
exl.Selection.NumberFormatLocal = "G/通用格式"
End If

exl.Cells(i + 1, j + 1) = clsTable(j, i)
Next
'显示写入进度
pgb.Value = i
labTiShi.Caption = "正在处理数据,请稍等...... " & clsNum - i

End If
Next

'移动焦点
exl.Range("A1").Select
'显示生成的表格
exl.Visible = True
Set exl = Nothing
strWhere = ""
Erase clsTable()
PuTongChaXun = True
End If

Exit Function
err1:
exl.DisplayAlerts = False
exl.Quit
exl.DisplayAlerts = True
Set exl = Nothing
exitF = False
PuTongChaXun = False
End Function

回复
lihonggen0 2003-04-01


------------------------------------------------------------------
个人专栏:http://www.csdn.net/develop/author/netauthor/lihonggen0/
------------------------------------------------------------------
回复
Cooly 2003-04-01
类似代码在以前的帖子中已经出现过,VB版的FAQ中也有相应的代码,楼主可以自己去查一下。这样不是可以节省一些可用分吗?
回复
cer 2003-04-01
并且显示在介面上,且可修改,且可把结果再保存为Excel文件
回复
相关推荐
发帖

1187

社区成员

VB 数据库(包含打印,安装,报表)
申请成为版主
帖子事件
创建了帖子
2003-03-29 02:05
社区公告
暂无公告