以前用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
分享到：
评论