ASP导出EXCEL文档
时间:2006-08-17 来源:muzhouren
    <%
    server.scripttimeout=100000   '处理时间较长,设置值应大一点
    On Error Resume Next
    set objExcelApp = server.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="db/db.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 table1",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 = "吉盟首饰"  '单元格插入数据
    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 = 30  '设置单元格字号
    objSpreadsheet.Cells(iRow, iCol).ParagraphFormat.Alignment=1 '设置单元格对齐格式:居中
    objspreadsheet.Cells(iRow,iCol).font.name="隶书" '设置单元格字体
    objspreadsheet.Cells(iRow,iCol).font.ColorIndex=5 '设置单元格文字的颜色
    objSpreadsheet.Range("A1:F1").merge   '合并单元格(单元区域)
    objSpreadsheet.Range("A1:F1").Interior.ColorIndex = 2  '设计单元络背景色
    '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.name="宋体"
    objSpreadsheet.Cells(iRow, iCol).Font.Italic = False
    objSpreadsheet.Cells(iRow, iCol).Font.Size = 12
    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 = "MakeExcel/" & SaveName & ".xls"
    objExcelBook.SaveAs server.mappath(ExcelPath)
    response.write("<a href='" & server.URLEncode(ExcelPath) & "'>下载</a>")
    objExcelApp.Quit
    set objExcelApp = Nothing
    %>
  










