杰哥个人博客|杰哥博客|厦门杰哥|杰哥主页|杰哥个人网站|杰哥网站

<%
'***************************************************************************************
'surnfu 2009-11-18 surnfu@126.com
'使用说明
'Dim excel
'set excel=new ReadExcel
'    excel.Path="/sys/exam/excel/1E65F051-E664-4D63-821B-F13D9709E1C1DB8A6827-5FCC-4F01-A40E-08F9DC2CC9E0.xls"
'    excel.Open()
'    if excel.Excelexist then
'        excel.OpenSheet("训后评估结果")
'        if excel.Sheetexist then
'            excel.readArea="C7:H23"
'            excel.reAllocation=false
'            Dim data : data=excel.Data()
'            response.Write(excel.MinRowNo &"<br>")
'            response.Write(excel.MaxRowNo &"<br>")
'            response.Write(excel.MinColNo &"<br>")
'            response.Write(excel.MaxColNo &"<br>")
'            response.Write(excel.GetCell("F12") &"<br>")
'            response.Write(data(12, 4) &"<br>")
'        end if
'    end if
'Set excel=nothing
'设置COM组件的操作权限。在命令行键入“DCOMCNFG”，则进入COM组件配置界面，选择MicrosoftExcel后点击属性按钮，将三个单选项一律选择自定义，编辑中将Everyone加入所有权限
'****************************************************************************************
Class ReadExcel
    Rem 只读属性
    Rem UsedTime       读取使用时间
    Rem Excelexist     执行Open()后判断excel是否存在
    Rem Sheetexist     执行OpenSheet(sheetName or sheetID)后判断工作簿是否存在
    Rem Sheets         执行Open()后，工作簿集合
    Rem ActiveSheet    执行OpenSheet(sheetName or sheetID)后，当前激活的工作簿
    Rem ActiveData     执行Data()后，取得的数据
    Rem MinColNo     取得数据开始行
    Rem MaxColNo     取得数据结束行
    Rem MinRowNo     取得数据开始列
    Rem MaxRowNo     取得数据结束列
    '======================================
    Rem 只写属性
    Rem readArea    执行OpenSheet(sheetName or sheetID)后，设置获取数据区域 “B2”，标示获取B2的数据值， Data()返回文本
    Rem “5:9” 表示获取第5行内，第9列内数据，Data()返回 二维数组 value(行数，列数)
    Rem “C7:H23” 表示获取第7行至第23行内，第C列至第H列内数据，Data()返回 二维数组 value(行数，列数)
    
    Rem reAllocation 当readArea为“C7:H23”格式时， 当设置reAllocation=true时，那么Data()返回数据下标从1开始，否则从数据区域起始行列开始，默认true
    '======================================
    Rem 读写属性
    Rem Path 设置读取Excel路径
    '======================================
    Rem 公共方法
    Rem  Open() 打开excel
    Rem  OpenSheet(SheetFlag) 打开sheet   SheetFlag为工作簿名称或者序号
    '======================================
    Rem 公共函数
    Rem Data() 或者工作簿数据, 当不设置readArea时，自动获取有数据区域数据，返回数据类型请看readArea设置部分
    Rem GetCell(CellName_) 获取单元格为CellName_的值
    '============end=======================
    Private AuthorStr              Rem 设置作者
    Private VersionStr          Rem 设置版本
    Private SystemStr              Rem 设置系统名称
    
    Private UsedTime_            Rem 使用的时间
    Private BeginTime_
    Private readPath_
    Private readArea_            Rem 格式 “10:13”表示读取10行，13列。“B5:F20”表示读取B5至F20区域。 “D10”表示读取D10单元格
    Private ArrRangArea_        Rem array(B(列数):5:F(列数):20)
    Private Excelexist_            Rem Excel是否存在
    Private Sheetexist_            Rem 表是否存在
    'Private Data_                 Rem 读取数据
    'Private tempData_             Rem 读取数据
    Private    reAllocation_          Rem 重新分配
    Private    MinColNo_              Rem 最小行号
    Private    MaxColNo_              Rem 最大行号
    Private    MinRowNo_              Rem 最小列号
    Private    MaxRowNo_              Rem 最大列号
    
    Private ExcelApp             Rem Excel.Application
    Private ExcelBook
    Private ExcelSheets
    Private ActiveSheet_
    Private ActiveData_
    Private Sub Class_Initialize()
        Server.ScriptTimeOut = 99999
        BeginTime_ = Timer
        SystemStr            =    "Lc00_ReadExcelServer"
        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
        reAllocation_=true
        ActiveData_=null
        readArea_=null
        ArrRangArea_=null
        Excelexist_=false
        Sheetexist_=false
    End Sub

    Private Sub Class_Terminate()
        ExcelApp.Quit
        ActiveSheet
        If Isobject(ActiveSheet_)     Then Set ActiveSheet_    =    Nothing
        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 Path(ByVal Val)
        If Instr(Val, ":\")<>0 Then
            readPath_ = Trim(Val)
        else
            readPath_=Server.MapPath(Trim(Val))
        end if
    End Property
    Public Property Let readArea(ByVal Val)
        Val = Replace(Replace(Val, " ", ""), "：", ":")
        if instr(Val, ":")<=0 then
            if not RegExpTest("^[A-Z]{1,3}[0-9]{1,5}$", Val) then
                InErr("读取区域设置错误")
            end if
            
            if RegExpTest("^[A-Z]{1,3}0{1,5}$", Val) then
                InErr("读取区域设置错误")
            end if
            
        else
            Dim tempArrReadArea : tempArrReadArea=SPlit(Val, ":")
            if isnumeric(tempArrReadArea(0)) then
                if not RegExpTest("^[0-9]{1,5}:[0-9]{1,5}$", Val) then
                    InErr("读取区域设置错误")
                end if
                
                if RegExpTest("^0{1,5}:0{1,5}$", Val) then
                    InErr("读取区域设置错误")
                end if
                ArrRangArea_=split(Val, ":")
                ArrRangArea_(0)=Clng(ArrRangArea_(0))
                ArrRangArea_(1)=Clng(ArrRangArea_(1))
            else
                if not RegExpTest("^[A-Z]{1,3}[0-9]{1,5}:[A-Z]{1,3}[0-9]{1,5}$", Val) then
                    InErr("读取区域设置错误")
                end if
                if RegExpTest("^[A-Z]{1,3}0{1,5}:[A-Z]{1,3}0{1,5}$", Val) then
                    InErr("读取区域设置错误")
                end if
            
                ArrRangArea_=Split(RegExpReplace("^([A-Z]{1,3})([0-9]{1,5}):([A-Z]{1,3})([0-9]{1,5})$", Val, "$1:$2:$3:$4"), ":")
                ArrRangArea_(0)=GetExcelColNum(ArrRangArea_(0))
                ArrRangArea_(1)=Clng(ArrRangArea_(1))
                ArrRangArea_(2)=GetExcelColNum(ArrRangArea_(2))
                ArrRangArea_(3)=Clng(ArrRangArea_(3))
                if ArrRangArea_(0)=-1 or ArrRangArea_(2)=-1 then
                    InErr("读取区域设置错误")
                end if
                if ArrRangArea_(0) > ArrRangArea_(2)then
                    InErr("读取区域设置错误，开始列不能大于结束列")
                end if
                if ArrRangArea_(1) > ArrRangArea_(3)then
                    InErr("读取区域设置错误，开始行不能大于结束行")
                end if
            end if
        end if
        readArea_=Val
    End Property
    Public Property Let reAllocation(ByVal Val)
        If Lcase(TypeName(Val))="boolean" Then
            reAllocation_ = Val
        end if
    End Property
    Public Property Get Path()
        Path = readPath_
    End Property
    Public Property Get UsedTime()
          UsedTime = UsedTime_
    End Property
    
    Public Property Get Excelexist()
          Excelexist = Excelexist_
    End Property
    
    Public Property Get Sheetexist()
          Sheetexist = Sheetexist_
    End Property
    Public Property Get ActiveData()
          ActiveData = ActiveData_
    End Property
    
    
    Public Property Get MinColNo()
          MinColNo = MinColNo_
    End Property
    
    Public Property Get MaxColNo()
          MaxColNo = MaxColNo_
    End Property
    
    Public Property Get MinRowNo()
          MinRowNo = MinRowNo_
    End Property
    
    Public Property Get MaxRowNo()
          MaxRowNo = MaxRowNo_
    End Property
    
    Public Property Get Sheets()
        If Isobject(ExcelSheets) Then
            Set Sheets = ExcelSheets
        else
            Sheets=null    
        end if    
    End Property
    
    
    Public Property Get ActiveSheet()
        If Isobject(ActiveSheet_) Then
            Set ActiveSheet = ActiveSheet_
        else
            ActiveSheet=null    
        end if    
    End Property
    
    Public sub Open()
        Excelexist_=false
        if readPath_="" then InErr("请设置Excel路径")
        on Error Resume Next
        ExcelApp.WorkBooks.Open(readPath_)
        if Err.number<>0 then
            Excelexist_=false
            Err.clear
            Err = 0
        else
            Excelexist_=true
            set ExcelBook = ExcelApp.ActiveWorkBook
            set ExcelSheets = ExcelBook.Worksheets
        end if
    End sub
    Public sub OpenSheet(SheetFlag)
        if Excelexist_=false then InErr("Excel文件不存在")
        readArea_=null
        ArrRangArea_=null
        Sheetexist_=false
        ActiveData_=null
        if SheetFlag="" then InErr("请设置工作簿名称")
        on Error Resume Next
        if isnumeric(SheetFlag) then
            Set ActiveSheet_=ExcelSheets(SheetFlag)
        else
            Set ActiveSheet_=ExcelBook.Sheets(SheetFlag)
        end if
        if Err.number<>0 then
            Sheetexist_=false
            Err.clear
            Err = 0
        else
            Sheetexist_=true
            ActiveSheet_.Activate
        end if
    End sub
    
    Public Function Data()
        MinColNo_ = -1
        MaxColNo_ = -1
        MinRowNo_ = -1
        MaxRowNo_ = -1
        if Sheetexist_=false then Data=null : ActiveData_=null : exit Function
        Dim ix_, iz_
        Dim tempReArrDatavalue_
        if isnull(readArea_) then
            Dim temprowsNum_ : temprowsNum_=ActiveSheet_.UsedRange.Rows.Count  
            Dim tempcolsNum_ : tempcolsNum_=ActiveSheet_.UsedRange.Columns.Count  
            Dim tempArrExcelData_
            ReDim tempArrExcelData_(temprowsNum_, tempcolsNum_)
            For ix_=1 to temprowsNum_
                For iz_=1 to tempcolsNum_
                    tempArrExcelData_(ix_, iz_)=ActiveSheet_.Cells(ix_, iz_).value
                Next
            Next
            Dim tempCosAndRow : tempCosAndRow=GetMaxColAndRow(tempArrExcelData_) '获取最大使用行列
            ReDim tempReArrDatavalue_(tempCosAndRow(0), tempCosAndRow(1)) '重新赋值
            
            For ix_=1 to tempCosAndRow(0)
                For iz_=1 to tempCosAndRow(1)
                    tempReArrDatavalue_(ix_, iz_)=tempArrExcelData_(ix_, iz_)
                Next
            Next
            
            MinRowNo_ = 1
            MaxRowNo_ = tempCosAndRow(0)
            MinColNo_ = 1
            MaxColNo_ = tempCosAndRow(1)
            Data=tempReArrDatavalue_
            ActiveData_=tempReArrDatavalue_
            UsedTime_ = FormatNumber((Timer - BeginTime_)*1000, 3)
            Exit Function
        end if
        if readArea_="" then  Data=null : ActiveData_=null : exit Function
        
        if Instr(readArea_, ":")<=0 then
            ActiveData_=GetSingleRange(readArea_)
            Data=ActiveData_
            UsedTime_ = FormatNumber((Timer - BeginTime_)*1000, 3)
            Exit Function
        else
            if isnumeric(Split(readArea_, ":")(0)) then
                MinRowNo_ = 1
                MaxRowNo_ = ArrRangArea_(0)
                MinColNo_ = 1
                MaxColNo_ = ArrRangArea_(1)
                ReDim tempReArrDatavalue_(ArrRangArea_(0), ArrRangArea_(1))
                For ix_=1 to MaxRowNo_
                    For iz_=1 to MaxColNo_
                        tempReArrDatavalue_(ix_, iz_) = GetSingleCell(ix_, iz_)
                    Next
                Next
                Data=tempReArrDatavalue_
                ActiveData_=tempReArrDatavalue_
                UsedTime_ = FormatNumber((Timer - BeginTime_)*1000, 3)
                Exit Function
            else    
                if reAllocation_=true then
                    MinRowNo_ = 1
                    MaxRowNo_ = ArrRangArea_(3) - ArrRangArea_(1) + 1
                    MinColNo_ = 1
                    MaxColNo_ = ArrRangArea_(2) - ArrRangArea_(0) + 1
                else
                    MinRowNo_ = ArrRangArea_(1)
                    MaxRowNo_ = ArrRangArea_(3)
                    MinColNo_ = ArrRangArea_(0)
                    MaxColNo_ = ArrRangArea_(2)
                end if
                ReDim tempReArrDatavalue_(MaxRowNo_, MaxColNo_)
                Dim tempix_, tempiz_
                For ix_=MinRowNo_ to MaxRowNo_
                    For iz_=MinColNo_ to MaxColNo_
                        if reAllocation_=true then
                            tempix_=ArrRangArea_(1) + ix_ - 1
                            tempiz_=ArrRangArea_(0) + iz_ - 1
                        else
                            tempix_=ix_
                            tempiz_=iz_
                        end if
                        tempReArrDatavalue_(ix_, iz_) = GetSingleCell(tempix_, tempiz_)
                    Next
                Next
                Data=tempReArrDatavalue_
                ActiveData_=tempReArrDatavalue_
                UsedTime_ = FormatNumber((Timer - BeginTime_)*1000, 3)
                Exit Function
            end if
        end if
    End Function
    
    
    
    Public Function GetCell(CellName_)
        if not RegExpTest("^[A-Z]{1,3}[0-9]{1,5}$", CellName_) then
            InErr("单元格名称错误")
        end if
        if RegExpTest("^[A-Z]{1,3}0{1,5}$", CellName_) then
            InErr("单元格名称错误")
        end if
        if isnull(ActiveData_) then
            GetCell=GetSingleRange(CellName_)
            Exit Function
        end if
        
        if not isarray(ActiveData_) then
            if readArea_=ActiveData_ then
                GetCell=ActiveData_
                Exit Function
            else
                GetCell=GetSingleRange(CellName_)
                Exit Function
            end if
        end if
        
        Dim arrCellName_ : arrCellName_=Split(RegExpReplace("^([A-Z]{1,3})([0-9]{1,5})$", CellName_, "$1:$2"), ":")
        arrCellName_(0)=GetExcelColNum(arrCellName_(0))
        arrCellName_(1)=Clng(arrCellName_(1))
        if arrCellName_(0)=-1 then
            GetCell=null
            Exit Function
        end if
    
        if arrCellName_(1)<ArrRangArea_(1) or arrCellName_(1)>ArrRangArea_(3) then
            GetCell=GetSingleRange(CellName_)
            Exit Function
        end if
        if arrCellName_(0)<ArrRangArea_(0) or arrCellName_(0)>ArrRangArea_(2) then
            GetCell=GetSingleRange(CellName_)
            Exit Function
        end if
        
        if reAllocation_=false then
            GetCell=ActiveData_(arrCellName_(1), arrCellName_(0))
            Exit Function
        End if
        GetCell=ActiveData_((arrCellName_(1)- ArrRangArea_(1) + 1), (arrCellName_(0) - ArrRangArea_(0) + 1))
    End Function
    
    Private Function GetMaxColAndRow(ArrExDate_)
        Dim iu_, iw_
        Dim tempMaxColsNum_, temMaxRowsNum_
        For iu_=1 to Ubound(ArrExDate_, 1)
            For iw_=1 to Ubound(ArrExDate_, 2)
                if ArrExDate_(iu_, iw_)<>""  then
                    temMaxRowsNum_=iu_
                    tempMaxColsNum_=iw_
                end if
            Next
        Next
        GetMaxColAndRow=array(temMaxRowsNum_, tempMaxColsNum_)
    End Function
    
    Private Function GetSingleRange(byval RangeName_)
        On error ReSume Next
        Dim reGValue_ : reGValue_=ActiveSheet_.Range(RangeName_).value
        if Err.Number<>0 then
            reGValue_=null
            Err.clear
            Err = 0
        end if
        GetSingleRange=reGValue_
    End Function
    Private Function GetSingleCell(byval Grow_, byval Gcol_)
        On error ReSume Next
        Dim reGValue_ : reGValue_=ActiveSheet_.Cells(Grow_, Gcol_).value
        if Err.Number<>0 then
            reGValue_=null
            Err.clear
            Err = 0
        end if
        GetSingleCell=reGValue_
    End Function
    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
    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 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)-1) & Arrlitter(((ColNum-1) mod 26))
        end if
        getColName = ReValue_
    End Function
    
    Rem 取得列数值
    Private Function GetExcelColNum(litter_)
        if litter_="" then GetExcelColNum=-1 : exit Function
        if not RegExpTest("^[A-Z]{1,5}$", litter_) then GetExcelColNum=-1 : exit Function
        Dim litterList_ : litterList_="ABCDEFGHIJKLMNOPQRSTUVWXYZ"
        Dim ia_, arra_
        ReDim arra_(Len(litter_))
        For ia_=1 to Len(litter_)
            arra_(ia_) = Instr(litterList_, mid(litter_, ia_, 1))
        Next
        Dim reNum_ : reNum_=0
        For ia_=1 to Len(litter_)
            if ia_<>Len(litter_) then
                reNum_=reNum_ + arra_(ia_) * 26 * (Len(litter_)-ia_)
            else
                reNum_=reNum_ + arra_(ia_)
            end if
        Next
        GetExcelColNum=reNum_
    end Function
    Private Function RegExpTest(patrn, strng)
        Dim regEx
        Set regEx = New RegExp
            regEx.Pattern = patrn
            regEx.IgnoreCase = false
            RegExpTest = regEx.Test(strng)
        Set regEx=nothing
    End Function
    Private Function RegExpReplace(patrn, strng, repStr)
        Dim regEx
        Set regEx = New RegExp
            regEx.Pattern = patrn
            regEx.IgnoreCase = false
            RegExpReplace = regEx.Replace(strng, repStr)
        Set regEx=nothing
    End Function
    Rem 设置错误
    Private Sub InErr(ErrInfo)
        Err.Raise vbObjectError + 1, SystemStr &"(Version "& VersionStr &")", ErrInfo
    End Sub
End Class
%>