代码如下:

<%

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

'使用说明

'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 surnfu@126.com 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 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("表数据设置有误")

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

%>

更多信息请查看IT技术专栏