<% 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文件——<a href="http://m.wsalc.com/" target="_blank" class="keylink">西部e網</a>" '單元格插入數據 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 %>