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
        
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_)*10003)
            
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_)*10003)
    
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(11)
                .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-1mod 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&"-"&&"我的"
    
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 ='二维数组             '多个工作表 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(falsetrue'首行是否为标题行
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
%>

posted on 2010-11-01 09:16 aiaiwoo 阅读(214) 评论(0)  编辑  收藏 所属分类: ASP/Visual Basic


只有注册用户登录后才能发表评论。


网站导航:
 
<2022年8月>
31123456
78910111213
14151617181920
21222324252627
28293031123
45678910

导航

统计

常用链接

留言簿

随笔分类

文章分类

文章档案

搜索

最新评论

阅读排行榜

评论排行榜