| 发表于：2007-11-16 21:37:572楼 得分:0 |
下面的函数很不错，调试一下吧
调用 exportoexcel 即可，输入 select 语句，及表名
注意：authors.xlt 是一个excel模板，将其第一行的指定列合并
例如： call exportoexcel （"select * from 表名",数据库名)
public function exportoexcel（byval strsql as string, byval datanames as string)
'建立一个ado数据连接
'若数据库连接出错，则转向connectionerr
on error goto connectionerr
'建立一个连接字串
if openfiles = true then
msgbox "数据库连接错误，" & err.description, vbcritical, "出错"
end if
'若recordset建立出错，则转向recordseterr
on error goto recordseterr
dim lngrowcount as integer
dim lngcolcount as integer
dim excelappx as excel.application
dim excelbookx as excel.workbook
dim excelsheetx as excel.worksheet
dim excelqueryx as excel.querytable
dim i as integer
'从表kcda查询
with datarec
if .state = adstateopen then
.close
end if
.activeconnection = dataconn
.cursorlocation = aduseclient
.cursortype = adopenstatic
.locktype = adlockreadonly
.source = strsql
.open
end with
lngrowcount = 0
do while （not datarec.eof)
lngrowcount = lngrowcount + 1 '记录总数
datarec.movenext
loop
with datarec
' if .recordcount < 1 then
' call msgbox（"没有记录!", vbexclamation, "错误")
' exit function
' end if
' '记录总数
' lngrowcount = .recordcount
'字段总数
lngcolcount = .fields.count
end with
on error goto excelerr
'建立excel应用程序
set excelappx = createobject（"excel.application")
'建立workbook
set excelbookx = excelappx.workbooks（).add（app.path & "\data\authors.xlt")
'建立表格sheet1
set excelsheetx = excelbookx.worksheets（"sheet1")
' excelappx.visible = true
'根据表头字段数设置表格列宽
for i = 0 to datarec.fields.count - 1
if len（datarec.fields（i).name) > 4 then
excelappx.range（convertxy2cell（i + 1, i + 1)).select
excelappx.activecell.cells.columnwidth = len（datarec.fields（i).name) * 2 + 1
else
excelappx.range（convertxy2cell（i + 1, i + 1)).select
excelappx.activecell.cells.columnwidth = 5 * 2 + 1
end if
next i
'添加查询，填充excel表格
'注意此句！！！
excelappx.range（convertxy2cell（1, 1)).select
'加粗
excelappx.activecell.font.bold = true
excelappx.activecell.font.size = 20
' excelappx.activecell.cells.columnwidth = excelappx.activecell.range（1, 1).width
'填写表头
excelappx.activecell.value = datanames
'从a3处向右下填充表格
set excelqueryx = excelsheetx.querytables.add（datarec, excelsheetx.range（"a2"))
'查询设置
with excelqueryx
'是否显示字段名
.fieldnames = true
'是否显示行号
.rownumbers = false
.filladjacentformulas = false
.preserveformatting = true
.refreshonfileopen = false
'后台搜索
.backgroundquery = true
'刷新样式
.refreshstyle = xlinsertdeletecells
.savepassword = true
'是否保存数据
.savedata = true
'是否自动调整列宽度
.adjustcolumnwidth = false
'自动刷新间距，设置为0是关闭自动刷新
.refreshperiod = 0
.preservecolumninfo = true
end with
'进行查询
excelqueryx.refresh
'设置字体和表格属性
with excelsheetx
.range（.cells（1, 1), .cells（lngrowcount + 2, lngcolcount)).borders.linestyle = xlcontinuous
'设表格边框样式
end with
'设置打印信息
with excelsheetx.pagesetup
.leftheader = "&""楷体_gb2312,常规""&10制表单位：调度室"
' .centerheader = "&""楷体_gb2312,常规""&10日期：" + cstr（date)
' .rightheader = "&""楷体_gb2312,常规""&10单位："
' .rightheader = "&""楷体_gb2312,常规""&10日期：" + cstr（date)
.leftfooter = "&""楷体_gb2312,常规""&10制表人："
.centerfooter = "&""楷体_gb2312,常规""&10制表日期：" & date
.rightfooter = "&""楷体_gb2312,常规""&10第&p页 共&n页"
end with
excelappx.application.visible = true
excelsheetx.printpreview
excelappx.displayalerts = false
excelappx.quit
set excelappx = nothing '"交还控制给excel
set excelbookx = nothing
set excelsheetx = nothing
datarec.close
dataconn.close
exit function
connectionerr:
'错误处理程序
msgbox "数据库连接错误，" & err.description, vbcritical, "出错"
exit function
recordseterr:
msgbox "recordset生成错误，" & err.description, vbcritical, "出错"
dataconn.close
exit function
excelerr:
msgbox "填充excel表格错误，" & err.description, vbcritical, "出错"
if not excelappx is nothing then excelappx.quit
datarec.close
dataconn.close
end function
private function convertxy2cell（byval lngcolumncount as long, byval lngrowcount) as string
'本函数将行列数转换为excel标示单元格的方式，如第一行第一列为a1
on error goto errout
convertxy2cell = convertcolumnname（lngcolumncount) & cstr（lngrowcount)
errout:
end function
private function convertcolumnname（lngcolumncount as long) as string
'本函数将列数转换为excel标示列的字母，如列1在excel为列a
dim number1 as long
dim number2 as long
dim tmpstring as string
on error goto errout
'计算第一个字母
number1 = int（lngcolumncount / 26)
'计算第二个字母
number2 = lngcolumncount mod 26
'判断列是否可以用一个字母表示
if number1 > 0 then
tmpstring = chr（number1 + 64) & chr（number2 + 64)
else
tmpstring = chr（number2 + 64)
end if
convertcolumnname = tmpstring
errout:
end function
| | |
|
