asp操作Excel类

 
<%
'***************************************************************************************
'使用说明
'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
        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 ExcelSheets = Nothing
        If Isobject(ExcelBook) Then ExcelBook = Nothing
        If Isobject(ExcelApp) Then 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
 
        ExcelBook = ExcelApp.ActiveWorkBook
        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_, ByVal DataId_)
        Dim Spreadsheet
        Dim tempSheetTitle
        Dim tempTitleFirstLine
        If DataId_ <> -1 Then
            If DataId_ > ExcelSheets.Count - 1 Then
                ExcelSheets.Add()
                Spreadsheet = ExcelBook.Sheets(1)
            Else
                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
            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
        Spreadsheet = Nothing
    End Sub
    REM 测试组件是否已经安装
    Private Function IsObjInstalled(ByVal strClassString)
        On Error Resume Next
        IsObjInstalled = False
        Err = 0
        Dim xTestObj
        xTestObj = Server.CreateObject(strClassString)
        If 0 = Err Then IsObjInstalled = True
        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(ByVal 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_, ByVal 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_, ByVal DataId_)
        Dim Spreadsheet
        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
        Spreadsheet = Nothing
    End Sub
    Public Function GetTime(ByVal 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
            End While
            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(ByVal 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
%>


上一篇：page_load的时候怎么知道是按了哪个按钮

下一篇：注册表单的规则

留下脚印压缩包密码:sosuo8
名字:
全部评论:
申明:本站部分文章来自网络,由于各种原因对文章的来源无从考究,如果您是“ asp操作Excel类 ”的原作者，若侵犯您的版权,请与我联系!在此请您原谅我的幼稚和无知!联系方法：email:ahuinan@21cn.com  QQ:106494262

感谢以下网友对网站提出的建议：
1、感谢“蓝树叶kiss”网友发现一个评论漏洞。(2009-2-28)
2、感谢“陈臣”对程序优化和seo方面的建议。(2009-3-18)
文章档案
  • 作者：surnfu
  • 来源：蓝色理想
  • 日期：2010-8-9 9:09:00
  • 点击：1935
网友投票(您觉得这篇文章怎样？)
loadding...请稍侯......

  

  

实用文章总结
文章阅读排行
随便看看
最新评论