程序代碼
<%
'***************************************************************************************
'使用說明
'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
        'http://www.devdao.com/
        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
%>