中文字幕免费精品_亚洲视频自拍_亚洲综合国产激情另类一区_色综合咪咪久久

代碼如下:

<%

'*******************************************************************

'使用說明

'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

%>

更多信息請查看IT技術專欄