代碼如下：
<%
'*******************************************************************
'使用說明
'Dim a
'Set a=new CreateExcel
'a.SavePath="x" '保存路徑
'a.SheetName="工作簿名稱" '多個工作表 a.SheetName=array("工作簿名稱一","工作簿名稱二")
'a.SheetTitle="表名稱" '可以為空 多個工作表 a.SheetName=array("表名稱一","表名稱二")
'a.Data =d '二維數組 '多個工作表 array(b,c) b與c為二維數組
'Dim rs
'Set rs=server.CreateObject("Adodb.RecordSet")
'rs.open "Select id, classid, className from [class] ",conn, 1, 1
'a.AddDBData rs, "字段名一，字段名二", "工作簿名稱", "表名稱", true 'true自動獲取表字段名
'a.AddData c, true , "工作簿名稱", "表名稱" 'c二維數組 true 第一行是否為標題行
'a.AddtData e, "Sheet1" '按模板生成 c=array(array("AA1", "內容"), array("AA2", "內容2"))
'a.Create()
'a.UsedTime 生成時間，毫秒數
'a.SavePath 保存路徑
'Set a=nothing
'設置COM組件的操作權限。在命令行鍵入“DCOMCNFG”，則進入COM組件配置界面，選擇MicrosoftExcel後點擊屬性按鈕，將三個單選項一律選擇自定義，編輯中將Everyone加入所有權限
'*******************************************************************
Class CreateExcel
Private CreateType_
Private savePath_
Private readPath_
Private AuthorStr Rem 設置作者
Private VersionStr Rem 設置版本
Private SystemStr Rem 設置系統名稱
Private SheetName_ Rem 設置表名
Private SheetTitle_ Rem 設置標題
Private ExcelData Rem 設置表數據
Private ExcelApp Rem Excel.Application
Private ExcelBook
Private ExcelSheets
Private UsedTime_ Rem 使用的時間
Public TitleFirstLine Rem 首行是否標題
Private Sub Class_Initialize()
Server.ScriptTimeOut = 99999
UsedTime_ = Timer
SystemStr = "Lc00_CreateExcelServer"
AuthorStr = "Surnfu [email protected] 31333716"
VersionStr = "1.0"
if not IsObjInstalled("Excel.Application") then
InErr("服務器未安裝Excel.Application控件")
end if
set ExcelApp = createObject("Excel.Application")
ExcelApp.DisplayAlerts = false
ExcelApp.Application.Visible = false
CreateType_ = 1
readPath_ = null
End SubPrivate Sub Class_Terminate()
ExcelApp.Quit
If Isobject(ExcelSheets) Then Set ExcelSheets = Nothing
If Isobject(ExcelBook) Then Set ExcelBook = Nothing
If Isobject(ExcelApp) Then Set ExcelApp = Nothing
End SubPublic Property Let ReadPath(ByVal Val)
If Instr(Val, ":")<>0 Then
readPath_ = Trim(Val)
else
readPath_=Server.MapPath(Trim(Val))
end if
End PropertyPublic Property Let SavePath(ByVal Val)
If Instr(Val, ":")<>0 Then
savePath_ = Trim(Val)
else
savePath_=Server.MapPath(Trim(Val))
end if
End Property
Public Property Let CreateType(ByVal Val)
if Val <> 1 and Val <> 2 then
CreateType_ = 1
else
CreateType_ = Val
end if
End Property
Public Property Let Data(ByVal Val)
if not isArray(Val) then
InErr("表數據設置有誤")
end if
ExcelData = Val
End Property
Public Property Get SavePath()
SavePath = savePath_
End Property
Public Property Get UsedTime()
UsedTime = UsedTime_
End Property
Public Property Let SheetName(ByVal Val)
if not isArray(Val) then
if Val = "" then
InErr("表名設置有誤")
end if
TitleFirstLine = true
else
ReDim TitleFirstLine(Ubound(Val))
Dim ik_
For ik_ = 0 to Ubound(Val)
TitleFirstLine(ik_) = true
Next
end if
SheetName_ = Val
End Property
Public Property Let SheetTitle(ByVal Val)
if not isArray(Val) then
if Val = "" then
InErr("表標題設置有誤")
end if
end if
SheetTitle_ = Val
End Property
Rem 檢查數據
Private Sub CheckData()
if savePath_ = "" then InErr("保存路徑不能為空")
if not isArray(SheetName_) then
if SheetName_ = "" then InErr("表名不能為空")
end if
if CreateType_ = 2 then
if not isArray(ExcelData) then
InErr("數據載入錯誤，或者未載入")
end if
Exit Sub
end if
if isArray(SheetName_) then
if not isArray(SheetTitle_) then
if SheetTitle_ <> "" then InErr("表標題設置有誤，與表名不對應")
end if
end if
if not IsArray(ExcelData) then
InErr("表數據載入有誤")
end if
if isArray(SheetName_) then
if GetArrayDim(ExcelData) <> 1 then InErr("表數據載入有誤，數據格式錯誤，維度應該為一")
else
if GetArrayDim(ExcelData) <> 2 then InErr("表數據載入有誤，數據格式錯誤，維度應該為二")
end if
End Sub
Rem 生成Excel
Public Function Create()
Call CheckData()
if not isnull(readPath_) then
ExcelApp.WorkBooks.Open(readPath_)
else
ExcelApp.WorkBooks.add
end if
set ExcelBook = ExcelApp.ActiveWorkBook
set ExcelSheets = ExcelBook.Worksheets
if CreateType_ = 2 then
Dim ih_
For ih_ = 0 to Ubound(ExcelData)
Call SetSheets(ExcelData(ih_), ih_)
Next
ExcelBook.SaveAs savePath_
UsedTime_ = FormatNumber((Timer - UsedTime_)*1000, 3)
Exit Function
end if
if IsArray(SheetName_) then
Dim ik_
For ik_ = 0 to Ubound(ExcelData)
Call CreateSheets(ExcelData(ik_), ik_)
Next
else
Call CreateSheets(ExcelData, -1)
end if
ExcelBook.SaveAs savePath_
UsedTime_ = FormatNumber((Timer - UsedTime_)*1000, 3)
End Function
Private Sub CreateSheets(ByVal Data_, DataId_)
Dim Spreadsheet
Dim tempSheetTitle
Dim tempTitleFirstLine
if DataId_<>-1 then
if DataId_ > ExcelSheets.Count - 1 then
ExcelSheets.Add()
set Spreadsheet = ExcelBook.Sheets(1)
else
set Spreadsheet = ExcelBook.Sheets(DataId_ + 1)
end if
if isArray(SheetTitle_) then
tempSheetTitle = SheetTitle_(DataId_)
else
tempSheetTitle = ""
end if
tempTitleFirstLine = TitleFirstLine(DataId_)
Spreadsheet.Name = SheetName_(DataId_)
else
set Spreadsheet = ExcelBook.Sheets(1)
Spreadsheet.Name = SheetName_
tempSheetTitle = SheetTitle_
tempTitleFirstLine = TitleFirstLine
end if
Dim Line_ : Line_ = 1
Dim RowNum_ : RowNum_ = Ubound(Data_, 1) + 1
Dim LastCols_
if tempSheetTitle <> "" then
'Spreadsheet.Columns(1).ShrinkToFit=true '設定是否自動適應表格單元大小(單元格寬不變）
LastCols_ = getColName(Ubound(Data_, 2) + 1)
with Spreadsheet.Cells(1, 1)
.value = tempSheetTitle
'設置Excel表裡的字體
.Font.Bold = True '單元格字體加粗
.Font.Italic = False '單元格字體傾斜
.Font.Size = 20 '設置單元格字號
.font.name="宋體" '設置單元格字體
'.font.ColorIndex=2 '設置單元格文字的顏色，顏色可以查詢，2為白色
End with
with Spreadsheet.Range("A1:"& LastCols_ &"1")
.merge '合並單元格(單元區域)
'.Interior.ColorIndex = 1 '設計單元絡背景色
.HorizontalAlignment = 3 '居中
End with
Line_ = 2
RowNum_ = RowNum_ + 1
end if
Dim iRow_, iCol_
Dim dRow_, dCol_
Dim tempLastRange : tempLastRange = getColName(Ubound(Data_, 2)+1) & (RowNum_)
Dim BeginRow : BeginRow = 1
if tempSheetTitle <> "" then BeginRow = BeginRow + 1
if tempTitleFirstLine = true then BeginRow = BeginRow + 1
if BeginRow=1 then
with Spreadsheet.Range("A1:"& tempLastRange)
.Borders.LineStyle = 1
.BorderAround -4119, -4138 '設置外框
.NumberFormatLocal = "@" '文本格式
.Font.Bold = False
.Font.Italic = False
.Font.Size = 10
.ShrinkToFit=true
end with
else
with Spreadsheet.Range("A1:"& tempLastRange)
.Borders.LineStyle = 1
.BorderAround -4119, -4138
.ShrinkToFit=true
end with
with Spreadsheet.Range("A"& BeginRow &":"& tempLastRange)
.NumberFormatLocal = "@"
.Font.Bold = False
.Font.Italic = False
.Font.Size = 10
end with
end if
if tempTitleFirstLine = true then
BeginRow = 1
if tempSheetTitle <> "" then BeginRow = BeginRow + 1
with Spreadsheet.Range("A"& BeginRow &":"& getColName(Ubound(Data_, 2)+1) & (BeginRow))
.NumberFormatLocal = "@"
.Font.Bold = True
.Font.Italic = False
.Font.Size = 12
.Interior.ColorIndex = 37
.HorizontalAlignment = 3 '居中
.font.ColorIndex=2
end with
end if
For iRow_ = Line_ To RowNum_
For iCol_ = 1 To (Ubound(Data_, 2) + 1)
dCol_ = iCol_ - 1
if tempSheetTitle <> "" then dRow_ = iRow_ - 2 else dRow_ = iRow_ - 1
If not IsNull(Data_(dRow_, dCol_)) then
with Spreadsheet.Cells(iRow_, iCol_)
.Value = Data_(dRow_, dCol_)
End with
End If
Next
Next
set Spreadsheet = Nothing
End Sub
Rem 測試組件是否已經安裝
Private Function IsObjInstalled(strClassString)
On Error Resume Next
IsObjInstalled = False
Err = 0
Dim xTestObj
Set xTestObj = Server.CreateObject(strClassString)
If 0 = Err Then IsObjInstalled = True
Set xTestObj = Nothing
Err = 0
End Function
Rem 取得數組維數
Private Function GetArrayDim(ByVal arr)
GetArrayDim = Null
Dim i_, temp
If IsArray(arr) Then
For i_ = 1 To 60
On Error Resume Next
temp = UBound(arr, i_)
If Err.Number <> 0 Then
GetArrayDim = i_ - 1
Err.Clear
Exit Function
End If
Next
GetArrayDim = i_
End If
End Function
Private Function GetNumFormatLocal(DataType)
Select Case DataType
Case "Currency":
GetNumFormatLocal = "￥#,##0.00_);(￥#,##0.00)"
Case "Time":
GetNumFormatLocal = "[$-F800]dddd, mmmm dd, yyyy"
Case "Char":
GetNumFormatLocal = "@"
Case "Common":
GetNumFormatLocal = "G/通用格式"
Case "Number":
GetNumFormatLocal = "#,##0.00_"
Case else :
GetNumFormatLocal = "@"
End Select
End Function
Public Sub AddDBData(ByVal RsFlied, ByVal FliedTitle, ByVal tempSheetName_, ByVal tempSheetTitle_, DBTitle)
if RsFlied.Eof then Exit Sub
Dim colNum_ : colNum_ = RsFlied.fields.count
Dim Rownum_ : Rownum_ = RsFlied.RecordCount
Dim ArrFliedTitle
if DBTitle = true then
FliedTitle = ""
Dim ig_
For ig_=0 to colNum_ - 1
FliedTitle = FliedTitle & RsFlied.fields.item(ig_).name
if ig_ <> colNum_ - 1 then FliedTitle = FliedTitle &","
Next
end if
if FliedTitle<>"" then
Rownum_ = Rownum_ + 1
ArrFliedTitle = Split(FliedTitle, ",")
if Ubound(ArrFliedTitle) <> colNum_ - 1 then
InErr("獲取數據庫表有誤，列數不符")
end if
end if
Dim tempData : ReDim tempData(Rownum_ - 1, colNum_ - 1)
Dim ix_, iy_
Dim iz
if FliedTitle<>"" then iz = Rownum_ - 2 else iz = Rownum_ - 1
For ix_ = 0 To iz
For iy_ = 0 To colNum_ - 1
if FliedTitle<>"" then
if ix_=0 then
tempData(ix_, iy_) = ArrFliedTitle(iy_)
tempData(ix_ + 1, iy_) = RsFlied(iy_)
else
tempData(ix_ + 1, iy_) = RsFlied(iy_)
end if
else
tempData(ix_, iy_) = RsFlied(iy_)
end if
Next
RsFlied.MoveNext
Next
Dim tempFirstLine
if FliedTitle<>"" then tempFirstLine = true else tempFirstLine = false
Call AddData(tempData, tempFirstLine, tempSheetName_, tempSheetTitle_)
End Sub
Public Sub AddData(ByVal tempDate_, ByVal tempFirstLine_, ByVal tempSheetName_, ByVal tempSheetTitle_)
if not isArray(ExcelData) then
ExcelData = tempDate_
TitleFirstLine = tempFirstLine_
SheetName_ = tempSheetName_
SheetTitle_ = tempSheetTitle_
else
if GetArrayDim(ExcelData) = 1 then
Dim tempArrLen : tempArrLen = Ubound(ExcelData)+1
ReDim Preserve ExcelData(tempArrLen)
ExcelData(tempArrLen) = tempDate_
ReDim Preserve TitleFirstLine(tempArrLen)
TitleFirstLine(tempArrLen) = tempFirstLine_
ReDim Preserve SheetName_(tempArrLen)
SheetName_(tempArrLen) = tempSheetName_
ReDim Preserve SheetTitle_(tempArrLen)
SheetTitle_(tempArrLen) = tempSheetTitle_
else
Dim tempOldData : tempOldData = ExcelData
ExcelData = Array(tempOldData, tempDate_)
TitleFirstLine = Array(TitleFirstLine, tempFirstLine_)
SheetName_ = Array(SheetName_, tempSheetName_)
SheetTitle_ = Array(SheetTitle_, tempSheetTitle_)
end if
end if
End Sub
Rem 模板增加數據方法
Public Sub AddtData(ByVal tempDate_, ByVal tempSheetName_)
CreateType_ = 2
if not isArray(ExcelData) then
ExcelData = Array(tempDate_)
SheetName_ = Array(tempSheetName_)
else
Dim tempArrLen : tempArrLen = Ubound(ExcelData)+1
ReDim Preserve ExcelData(tempArrLen)
ExcelData(tempArrLen) = tempDate_
ReDim Preserve SheetName_(tempArrLen)
SheetName_(tempArrLen) = tempSheetName_
End if
End Sub
Private Sub SetSheets(ByVal Data_, DataId_)
Dim Spreadsheet
set Spreadsheet = ExcelBook.Sheets(SheetName_(DataId_))
Spreadsheet.Activate
Dim ix_
For ix_ =0 To Ubound(Data_)
if not isArray(Data_(ix_)) then InErr("表數據載入有誤，數據格式錯誤")
if Ubound(Data_(ix_)) <> 1 then InErr("表數據載入有誤，數據格式錯誤")
Spreadsheet.Range(Data_(ix_)(0)).value = Data_(ix_)(1)
Next
set Spreadsheet = Nothing
End Sub
Public Function GetTime(msec_)
Dim ReTime_ : ReTime_=""
if msec_ < 1000 then
ReTime_ = msec_ &"MS"
else
Dim second_
second_ = (msec_ 1000)
if (msec_ mod 1000)<>0 then
msec_ = (msec_ mod 1000) &"毫秒"
else
msec_ = ""
end if
Dim n_, aryTime(2), aryTimeunit(2)
aryTimeunit(0) = "秒"
aryTimeunit(1) = "分"
aryTimeunit(2) = "小時"
n_ = 0
Dim tempSecond_ : tempSecond_ = second_
While(tempSecond_ / 60 >= 1)
tempSecond_ = Fix(tempSecond_ / 60 * 100) / 100
n_ = n_ + 1
WEnd
Dim m_
For m_ = n_ To 0 Step -1
aryTime(m_) = second_ (60 ^ m_)
second_ = second_ mod (60 ^ m_)
ReTime_ = ReTime_ & aryTime(m_) & aryTimeunit(m_)
Next
if msec_<>"" then ReTime_ = ReTime_ & msec_
end if
GetTime = ReTime_
end Function
Rem 取得列名
Private Function getColName(ByVal ColNum)
Dim Arrlitter : Arrlitter=split("A B C D E F G H I J K L M N O P Q R S T U V W X Y Z", " ")
Dim ReValue_
if ColNum <= Ubound(Arrlitter) + 1 then
ReValue_ = Arrlitter(ColNum - 1)
else
ReValue_ = Arrlitter(((ColNum-1) 26)) & Arrlitter(((ColNum-1) mod 26))
end if
getColName = ReValue_
End Function
Rem 設置錯誤
Private Sub InErr(ErrInfo)
Err.Raise vbObjectError + 1, SystemStr &"(Version "& VersionStr &")", ErrInfo
End Sub
End Class
Dim b(4,6)
Dim c(50,20)
Dim i, j
For i=0 to 4
For j=0 to 6
b(i,j) =i&"-"&j
Next
Next
For i=0 to 50
For j=0 to 20
c(i,j) = i&"-"&j &"我的"
Next
Next
Dim e(20)
For i=0 to 20
e(i)= array("A"&(i+1), i+1)
Next
'使用示例 需要xx.xls模板支持
'Set a=new CreateExcel
'a.ReadPath = "xx.xls"
'a.SavePath="xx-1.xls"
'a.AddtData e, "Sheet1"
'a.Create()
'response.Write("生成"& a.SavePath &" 使用了 "& a.GetTime(a.UsedTime) &"<br>")
'Set a=nothing
'使用示例一
Set a=new CreateExcel
a.SavePath="x.xls"
a.AddData b, true , "測試c", "測試c"
a.TitleFirstLine = false '首行是否為標題行
a.Create()
response.Write("生成"& a.SavePath &" 使用了 "& a.GetTime(a.UsedTime) &"<br>")
Set a=nothing
'使用示例二
Set a=new CreateExcel
a.SavePath="y.xls"
a.SheetName="工作簿名稱" '多個工作表 a.SheetName=array("工作簿名稱一","工作簿名稱二")
a.SheetTitle="表名稱" '可以為空 多個工作表 a.SheetName=array("表名稱一","表名稱二")
a.Data =b '二維數組 '多個工作表 array(b,c) b與c為二維數組
a.Create()
response.Write("生成"& a.SavePath &" 使用了 "& a.GetTime(a.UsedTime) &"<br>")
Set a=nothing
'使用示例三 生成兩個表
Set a=new CreateExcel
a.SavePath="z.xls"
a.SheetName=array("工作簿名稱一","工作簿名稱二")
a.SheetTitle=array("表名稱一","表名稱二")
a.Data =array(b, c) 'b與c為二維數組
a.TitleFirstLine = array(false, true) '首行是否為標題行
a.Create()
response.Write("生成"& a.SavePath &" 使用了 "& a.GetTime(a.UsedTime) &"<br>")
Set a=nothing
'使用示例四 需要數據庫支持
'Dim rs
'Set rs=server.CreateObject("Adodb.RecordSet")
'rs.open "Select id, classid, className from [class] ",conn, 1, 1
'Set a=new CreateExcel
'a.SavePath="a"
'a.AddDBData rs, "序號,類別序號,類別名稱", "工作簿名稱", "類別表", false
'a.Create()
'response.Write("生成"& a.SavePath &" 使用了 "& a.GetTime(a.UsedTime) &"<br>")
'Set a=nothing
'rs.close
'Set rs=nothing
%>
