asp操作Excel类_.docx

asp操作Excel类_ 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 surnfu126.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 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 = "$-F800dddd, 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) " ") 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) " ") 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) " ") Set a=nothing 用法示例三 生成两个表 Set a=new CreateExcel a.SavePath="z.xls" a.SheetName=array("工作簿名称一","工作簿名称二") a.