代碼如下:

<%

'*******************************************************************

'使用說(shuō)明

'Dim a

'Set a=new CreateExcel

'a.SavePath="x" '保存路徑

'a.SheetName="工作簿名稱(chēng)" '多個(gè)工作表 a.SheetName=array("工作簿名稱(chēng)一","工作簿名稱(chēng)二")

'a.SheetTitle="表名稱(chēng)" '可以為空 多個(gè)工作表 a.SheetName=array("表名稱(chēng)一","表名稱(chēng)二")

'a.Data =d '二維數(shù)組 '多個(gè)工作表 array(b,c) b與c為二維數(shù)組

'Dim rs

'Set rs=server.CreateObject("Adodb.RecordSet")

'rs.open "Select id, classid, className from [class] ",conn, 1, 1

'a.AddDBData rs, "字段名一，字段名二", "工作簿名稱(chēng)", "表名稱(chēng)", true 'true自動(dòng)獲取表字段名

'a.AddData c, true , "工作簿名稱(chēng)", "表名稱(chēng)" 'c二維數(shù)組 true 第一行是否為標(biāo)題行

'a.AddtData e, "Sheet1" '按模板生成 c=array(array("AA1", "內(nèi)容"), array("AA2", "內(nèi)容2"))

'a.Create()

'a.UsedTime 生成時(shí)間，毫秒數(shù)

'a.SavePath 保存路徑

'Set a=nothing

'設(shè)置COM組件的操作權(quán)限。在命令行鍵入“DCOMCNFG”，則進(jìn)入COM組件配置界面，選擇MicrosoftExcel后點(diǎn)擊屬性按鈕，將三個(gè)單選項(xiàng)一律選擇自定義，編輯中將Everyone加入所有權(quán)限

'*******************************************************************

Class CreateExcel

Private CreateType_

Private savePath_

Private readPath_

Private AuthorStr Rem 設(shè)置作者

Private VersionStr Rem 設(shè)置版本

Private SystemStr Rem 設(shè)置系統(tǒng)名稱(chēng)

Private SheetName_ Rem 設(shè)置表名

Private SheetTitle_ Rem 設(shè)置標(biāo)題

Private ExcelData Rem 設(shè)置表數(shù)據(jù)

Private ExcelApp Rem Excel.Application

Private ExcelBook

Private ExcelSheets

Private UsedTime_ Rem 使用的時(shí)間

Public TitleFirstLine Rem 首行是否標(biāo)題

Private Sub Class_Initialize()

Server.ScriptTimeOut = 99999

UsedTime_ = Timer

SystemStr = "Lc00_CreateExcelServer"

AuthorStr = "Surnfu surnfu@126.com 31333716"

VersionStr = "1.0"

if not IsObjInstalled("Excel.Application") then

InErr("服務(wù)器未安裝Excel.Application控件")

end if

set ExcelApp = createObject("Excel.Application")

ExcelApp.DisplayAlerts = false

ExcelApp.Application.Visible = false

CreateType_ = 1

readPath_ = null

End Sub

Private 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 Sub

Public Property Let ReadPath(ByVal Val)

If Instr(Val, ":")<>0 Then

readPath_ = Trim(Val)

else

readPath_=Server.MapPath(Trim(Val))

end if

End Property

Public 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("表數(shù)據(jù)設(shè)置有誤")

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("表名設(shè)置有誤")

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("表標(biāo)題設(shè)置有誤")

end if

end if

SheetTitle_ = Val

End Property

Rem 檢查數(shù)據(jù)

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("數(shù)據(jù)載入錯(cuò)誤，或者未載入")

end if

Exit Sub

end if

if isArray(SheetName_) then

if not isArray(SheetTitle_) then

if SheetTitle_ <> "" then InErr("表標(biāo)題設(shè)置有誤，與表名不對(duì)應(yīng)")

end if

end if

if not IsArray(ExcelData) then

InErr("表數(shù)據(jù)載入有誤")

end if

if isArray(SheetName_) then

if GetArrayDim(ExcelData) <> 1 then InErr("表數(shù)據(jù)載入有誤，數(shù)據(jù)格式錯(cuò)誤，維度應(yīng)該為一")

else

if GetArrayDim(ExcelData) <> 2 then InErr("表數(shù)據(jù)載入有誤，數(shù)據(jù)格式錯(cuò)誤，維度應(yīng)該為二")

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 '設(shè)定是否自動(dòng)適應(yīng)表格單元大小(單元格寬不變）

LastCols_ = getColName(Ubound(Data_, 2) + 1)

with Spreadsheet.Cells(1, 1)

.value = tempSheetTitle

'設(shè)置Excel表里的字體

.Font.Bold = True '單元格字體加粗

.Font.Italic = False '單元格字體傾斜

.Font.Size = 20 '設(shè)置單元格字號(hào)

.font.name="宋體" '設(shè)置單元格字體

'.font.ColorIndex=2 '設(shè)置單元格文字的顏色，顏色可以查詢(xún)，2為白色

End with

with Spreadsheet.Range("A1:"& LastCols_ &"1")

.merge '合并單元格(單元區(qū)域)

'.Interior.ColorIndex = 1 '設(shè)計(jì)單元絡(luò)背景色

.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 '設(shè)置外框

.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 測(cè)試組件是否已經(jīng)安裝

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 取得數(shù)組維數(shù)

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("獲取數(shù)據(jù)庫(kù)表有誤，列數(shù)不符")

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 模板增加數(shù)據(jù)方法

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("表數(shù)據(jù)載入有誤，數(shù)據(jù)格式錯(cuò)誤")

if Ubound(Data_(ix_)) <> 1 then InErr("表數(shù)據(jù)載入有誤，數(shù)據(jù)格式錯(cuò)誤")

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) = "小時(shí)"

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 設(shè)置錯(cuò)誤

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", "測(cè)試c"

a.TitleFirstLine = false '首行是否為標(biāo)題行

a.Create()

response.Write("生成"& a.SavePath &"　使用了 "& a.GetTime(a.UsedTime) &"<br>")

Set a=nothing

'使用示例二

Set a=new CreateExcel

a.SavePath="y.xls"

a.SheetName="工作簿名稱(chēng)" '多個(gè)工作表 a.SheetName=array("工作簿名稱(chēng)一","工作簿名稱(chēng)二")

a.SheetTitle="表名稱(chēng)" '可以為空 多個(gè)工作表 a.SheetName=array("表名稱(chēng)一","表名稱(chēng)二")

a.Data =b '二維數(shù)組 '多個(gè)工作表 array(b,c) b與c為二維數(shù)組

a.Create()

response.Write("生成"& a.SavePath &"　使用了 "& a.GetTime(a.UsedTime) &"<br>")

Set a=nothing

'使用示例三 生成兩個(gè)表

Set a=new CreateExcel

a.SavePath="z.xls"

a.SheetName=array("工作簿名稱(chēng)一","工作簿名稱(chēng)二")

a.SheetTitle=array("表名稱(chēng)一","表名稱(chēng)二")

a.Data =array(b, c) 'b與c為二維數(shù)組

a.TitleFirstLine = array(false, true) '首行是否為標(biāo)題行

a.Create()

response.Write("生成"& a.SavePath &"　使用了 "& a.GetTime(a.UsedTime) &"<br>")

Set a=nothing

'使用示例四 需要數(shù)據(jù)庫(kù)支持

'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, "序號(hào),類(lèi)別序號(hào),類(lèi)別名稱(chēng)", "工作簿名稱(chēng)", "類(lèi)別表", false

'a.Create()

'response.Write("生成"& a.SavePath &"　使用了 "& a.GetTime(a.UsedTime) &"<br>")

'Set a=nothing

'rs.close

'Set rs=nothing

%>

更多信息請(qǐng)查看IT技術(shù)專(zhuān)欄