vbscript、javascript快速导出Excel，并能任意设置格式，不支持合并单元格

codsoul

浏览: 212417 次
性别:
来自: 珠海

最近访客更多访客>>

刘文不是

sryijun

lslab

abun

博主相关

博客

微博

相册

留言

关于我

文章分类

社区版块

存档分类

以前用Javascript做了个导出函数，但速度很慢，后来采用粘贴的方式，速度提高了不少，
但是，刚开始时很快，到后面越来越慢，是因为占用内存的缘故，占用内存越来越多，速度就越来越慢，
找了一些回收内存的方式，但没有一个奏效的，无奈之下换成用VBScript来实现，因为VBScript有erase

换成用VBSCript后，却也没有变化，一直调试了几天，某天忽然发现导出特别快了，后面和前面一样的快，
跟踪内存，内存一直保持稳定，没有一直飑升，算法优化特别重要，比如一行：t.rows[i].cells[j] ，我把它拆开，避免每次都要从集合里取，速度也提高了一倍，效果图：进度条展示:

'快速导出，不支持合并单元格
isProgressErr = false
pageCount = 150   '每页记录数（一次粘贴一页的数据）。
function vbExportExcelFast(tabId,sTitle,sHeader,arrStrs,hasInput)
    window.event.returnValue = false
    tBegin = Timer()
    set t = document.getElementById(tabId).firstChild
    rows = t.childNodes.length
    cols = t.childNodes(0).childNodes.length
    'on error resume next '容错处理
    set oXL = createObject("Excel.Application")
    if (err.number>0) then
        msgbox("请确认已经安装了Excel并允许运行Excel!")
        exit function
    end if
    oXL.Workbooks.Add
    set obook = oXL.ActiveWorkBook
    set osheets = obook.Worksheets
    set osheet = obook.Sheets(1)
    xlrow = 1

    '设置第二列为文本
    if(arrStrs<>"") then
        sStrs = split(arrStrs,",")
        for i=0 to ubound(sStrs)
            nStr = CInt(sStrs(i))
            osheet.Range(osheet.Cells(xlrow, nStr),osheet.Cells(rows+xlrow,nStr)).Select
            oXL.Selection.NumberFormatLocal = "@"
        next
    end if
    '
    '添加标题
    osheet.Cells(1, 1) = sTitle
    osheet.Range(osheet.Cells(xlrow, 1),osheet.Cells(xlrow,cols)).Select
    oXL.Selection.HorizontalAlignment = 3
    oXL.Selection.MergeCells = true
    xlrow = xlrow + 1
    '添加小标题
    if(sHeader <> "") then
        osheet.Cells(2, 1) = sHeader
        osheet.Range(osheet.Cells(xlrow, 1),osheet.Cells(xlrow,cols)).Select
        oXL.Selection.MergeCells = true
        xlrow = xlrow + 1
    end if
    '进度条
    winX = (screen.width - 300) / 2
    winY = (screen.height - 120) / 2
    set win = window.open("","","directories=0,location=0,memubar=0,scrollbars=0,status=0,toolbar=0,width=230,height=75,left=" + cstr(winX) + ",top=" + cstr(winY))
    sProcess = vbmkProcessTxt(sTitle,rows)
    win.document.write(sProcess)
    set osx = win.document.getElementById("sx")
    set cells = win.document.getElementById("m_pub_wzs_progress_tab").rows(0).cells

    isProgressErr = false
    pages = (rows - (rows mod pageCount)) / pageCount
    if((rows mod pageCount) > 0) then
        pages = pages + 1
    end if
    'dim scs()

    for i = 0 to pages-1
        call vbExportExcelPage(i,cols,rows,osx,cells,t,osheet,xlrow,hasInput)
        call CollectGarbage()
        xlrow = xlrow + pageCount '不能用pageCount，因为有不满页的情况。
    next
    tEnd = Timer()
    ix = cint(tEnd-tBegin)
    if(not isProgressErr) then
        win.document.getElementById("info").innerText = "导出完毕，正在格式化... (" + cstr(ix) + "秒)"
    end if

    osheet.Range(osheet.Cells(1, 1),osheet.Cells(1,1)).Select '选择第一个单元格列
    osheet.Columns.AutoFit
    for i=1 to xlrow
        osheet.Rows(i).RowHeight = osheet.Rows(i).RowHeight + 6   '自动大小后上下无边距，需要增加高度，要不太挤。
    next
    if(not isProgressErr) then         '关闭进度条
        win.close()
    end if

    oXL.Visible = true
    oXL.UserControl = true

    set oXL = nothing
    set obook = nothing
    set osheets = nothing
    set osheet = nothing
end function

function vbExportExcelPage(i,cols,rows,osx,cells,t,osheet,xlrow,hasInput)
        dim scs()
        redim scs(pageCount-1,cols-1)
        'redim scs(pageCount*cols-1)
        for j=0 to pageCount-1
            iRow = i*pageCount+j
            if(iRow >= rows) then
                exit for
            end if
            set tr = t.childNodes(iRow)
            if(not isProgressErr) then
                'on error resume next
                call vb_progress_show(osx,cells,rows,iRow+1)
                if err.number > 0 then
                    isProgressErr = true
                end if
            end if
            for h=0 to cols-1
                set td = tr.childNodes(h) 't.childNodes(iRow).cells(h)
                s = ""
                if hasInput then
    '                if( (h=colMileage) and (iRow>0) and (iRow<rows-1) )then
                    if(td.hasChildNodes()) then
                        if (lcase(td.firstChild.nodeName)="input") then
                            if (lcase(td.firstChild.type)="text") then
                                s = td.firstChild.value
                    'elseif((h=colWay) and (iRow>0) and (iRow<rows-1)) then
                            elseif (lcase(td.firstChild.type) = "radio") then
                                if (td.firstChild.checked) then
                                    s = "1"
                                else
                                    s = "2"
                                end if
                            end if
                        else
                            s = td.innerText
                        end if
                    else
                        s = td.innerText
                    end if
                else
                    s = td.innerText
                end if

                scs(j, h) = s
            next
        next
        osheet.Range(osheet.Cells(xlrow, 1),osheet.Cells(xlrow+pageCount-1,cols)).value = scs
        erase scs
        call CollectGarbage()
end function

function vbmkProcessTxt(sTitle,rows)
    s = "<html><title>" + sTitle + "导出Excel</title><body><div id='m_pub_wzs_progress_x' style='background:white;font-size:9pt;overflow:hidden;padding-top:0;position:absolute;left:10px;top:16px;'>{0}<table id='m_pub_wzs_progress_tab' border=0 cellspacing=1 bgcolor='#CCCCCC' style='border-width:1px;border-style:solid;border-left-color:#333333;border-top-color:#333333;border-right-color:#EEEEEE;border-bottom-color:#EEEEEE;'><tr height=17>"
    dim ss(19)
    for i=0 to 19
        ss(i) = "<td width=16 bgcolor='#CCCCCC'></td>"
    next
    s = s + join(ss,"")
    skeydu = "<img src='../../js/kedu.jpg'>"
    s = replace(s,"{0}",skeydu)
    s = s + "</tr></table><span id='m_pub_wzs_progress_percent' style='font-size:10pt;vertical-align:middle;color:black;font-family:宋体'>总计" + cstr(rows) + "行，已导出<font id='sx' color='#cc0000'></font>行！<br /><font id='info' color='#008800'></font></span></div><br /><br /><br /></body></html>"
    vbmkProcessTxt= s
end function
dim m_progressNum
m_progressNum = 0
function vb_progress_show(osx,pCells,pTotalCount,pCurrCount)
    osx.innerText = cstr(pCurrCount)
    m = Int(pCurrCount / pTotalCount * 20)
    if((m<>m_progressNum) and (m>0)) then
        pCells(m-1).bgColor="#000088"
    end if
    m_progressNum = m
end function