主题:  怎样将留言导入到excel中

lizhongjun
职务：普通成员
等级：1
金币：0.0
发贴：7
注册：2006/5/21 12:15:46
#12006/6/5 13:51:57
各位大虾帮帮忙，我想把留言板中的留言导入到excel中，怎么实现？必须有分时间导入功能。就像那种“点击下载”直接就下载到excel中，还能分日期下载



yiliaocheng
职务：普通成员
等级：2
金币：2.0
发贴：631
注册：2005/12/29 19:33:15
#22006/6/5 15:27:41
给你一个代码，自己研究吧。
<%
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 Conn
Dim Connstr
Dim DB
DB="weste.mdb" \'这里选择数据库
Set conn = Server.CreateObject("ADODB.Connection")
Connstr="Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Server.MapPath(DB)
Conn.Open Connstr
Dim objRS
Set objRS = Server.CreateObject("ADODB.Recordset")
objRS.Open "SELECT * FROM FriendLink",conn,1,3 \'这里用sql语句查询需要导出的内容
If objRS.EOF then
response.write("Error")
respose.end
End if

Dim objField, iCol, iRow
iCol = 1 \'取得列号
iRow = 1 \'取得行号
objSpreadsheet.Cells(iRow, iCol).value = "用ASP将Access中的数据导入到Excel文件——西部e网" \'单元格插入数据
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="temp1"
Dim objExcel
Dim ExcelPath
ExcelPath = "" & SaveName & ".xls"
objExcelBook.SaveAs server.mappath(ExcelPath)
response.write("<a href=\'" & server.URLEncode(ExcelPath) & "\'>下载</a>")
objExcelApp.Quit
set objExcelApp = Nothing
%>