网站首页  汉语字词  英语词汇  考试资料  写作素材  旧版资料

请输入您要查询的考试资料：

　

标题 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_)*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 = "[$-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
    %>
随便看

　

在线学习网考试资料包含高考、自考、专升本考试、人事考试、公务员考试、大学生村官考试、特岗教师招聘考试、事业单位招聘考试、企业人才招聘、银行招聘、教师招聘、农村信用社招聘、各类资格证书考试等各类考试资料。

　

Copyright © 2002-2024 cuapp.net All Rights Reserved
更新时间：2025/5/13 7:07:30