操作Excel的asp程序代码

<%
'***************************************************************************************

'使用说明
'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 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 temps教程heettitle
        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) &"
")
'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) &"
")
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) &"
")
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) &"
")
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) &"
")
'set a=nothing
'rs.close
'set rs=nothing

%>