Office中国论坛/Access中国论坛

标题: [求助]数据库导出为excel文件的问题 [打印本页]

作者: dnxp 时间: 2006-9-22 04:13
标题: [求助]数据库导出为excel文件的问题
请大家帮帮我，下面是数据库导出为excel文件，但是在2000下导出后是表头，在xp下提示导出成功，可是什么没有，导出的文件也没有。（student是表名 dh是字段 13是要查找的）

Dim xibua
Dim mysql
xibua = Request.QueryString("13")
if xibua="" Then
mysql="select * from student"
Else
mysql="select * from student where [dh]='"& xibua &"'"
End If
server.scripttimeout=100000'处理时间较长,设置值应大一点
On Error Resume Next
set objExcelApp = CreateObject("Excel.Application")
objExcelApp.DisplayAlerts = false
objExcelApp.Application.Visible = false
objExcelApp.WorkBooks.add
set objExcelBook = objExcelApp.ActiveWorkBook
set objExcelSheets = objExcelBook.Worksheets
set objSpreadsheet = objExcelBook.Sheets(1)
Dim objRS
Set objRS = Server.CreateObject("ADODB.Recordset")
objRS.Open mysql,conn,1,3
If objRS.EOF then
response.write("Error")
respose.end
End if
Dim objField,iCol,iRow
iCol = 1 '取得列号
iRow = 1 '取得行号
objSpreadsheet.Cells(iRow,iCol).value = ""&xibua&"student"'单元格插入数据
objSpreadsheet.Columns(iCol).ShrinkToFit=true'设定是否自动适应表格单元大小(单元格宽不变)
'设置Excel表里的字体
objSpreadsheet.Cells(iRow,iCol).Font.Bold = True'单元格字体加粗
objSpreadsheet.Cells(iRow,iCol).Font.Italic = False'单元格字体倾斜
objSpreadsheet.Cells(iRow,iCol).Font.Size = 20'设置单元格字号
objSpreadsheet.Cells(iRow,iCol).ParagraphFormat.Alignment=1'设置单元格对齐格式:居中
objspreadsheet.Cells(iRow,iCol).font.name="宋体"'设置单元格字体
objspreadsheet.Cells(iRow,iCol).font.ColorIndex=2'设置单元格文字的颜色,颜色可以查询,2为白色
objSpreadsheet.Range("A1:F1").merge'合并单元格(单元区域)
objSpreadsheet.Range("A1:F1").Interior.ColorIndex = 1'设计单元络背景色
'objSpreadsheet.Range("A2:F2").WrapText=true'设置字符回卷(自动换行)
iRow=iRow+1
For Each objField in objRS.Fields
'objSpreadsheet.Columns(iCol).ShrinkToFit=true
objSpreadsheet.Cells(iRow,iCol).value = objField.Name
'设置Excel表里的字体
objSpreadsheet.Cells(iRow,iCol).Font.Bold = True
objSpreadsheet.Cells(iRow,iCol).Font.Italic = False
objSpreadsheet.Cells(iRow,iCol).Font.Size = 20
objSpreadsheet.Cells(iRow,iCol).Halignment = 2'居中
iCol = iCol + 1
Next 'objField
'Display all of the data
Do While Not objRS.EOF
iRow = iRow + 1
iCol = 1
For Each objField in objRS.Fields
If IsNull(objField.value)then
objSpreadsheet.Cells(iRow,iCol).value = ""
Else
objSpreadsheet.Columns(iCol).ShrinkToFit=true
objSpreadsheet.Cells(iRow,iCol).value = objField.value
objSpreadsheet.Cells(iRow,iCol).Halignment = 2
objSpreadsheet.Cells(iRow,iCol).Font.Bold = False
objSpreadsheet.Cells(iRow,iCol).Font.Italic = False
objSpreadsheet.Cells(iRow,iCol).Font.Size = 10
'objSpreadsheet.Cells(iRow,iCol).Halignment = 2
objSpreadsheet.Cells(iRow,iCol).ParagraphFormat.Alignment=1
End If
iCol = iCol + 1
Next'objField
objRS.MoveNext
Loop
Dim SaveName
SaveName=year(now)&month(now)&day(now)&hour(now)&minute(now)&second(now)
Dim objExcel
Dim ExcelPath
ExcelPath = "Excel\"&SaveName&".xls"
objExcelBook.SaveAs server.mappath(ExcelPath)
Response.Write"<center><b>导出成功,请选择继续操作</b></center>"
response.Write"<table width=90% bgcolor=gray bgcolor=CCCCCC cellspacing=1 cellpadding=3 align=center>"
Response.Write"<tr align=center bgcolor=#6699CC style=color:white> <td>"
response.write("<font color=green>√</font><a href='"& ExcelPath & "'>下载 </a>")&"<font color=green>√</font><A href=javascript:history.back()>返回上一页</a>"
Response.Write "</td></tr></table>"
objExcelApp.Quit
set objExcelApp = Nothing

作者: 浩雨 时间: 2006-9-22 09:14
用 DoCmd.OutputTo 就可以导出了

欢迎光临 Office中国论坛/Access中国论坛 (http://www.office-cn.net/)