<% '歡迎與我交流和學習 '作者:幸福的子彈 'BLOG:http://mysheji.com/blog 'E-mail:zhaojiangang@gmail.com 'QQ:37294812 '----------------------------------------------------------------------------- '開啟容錯機制 on error resume next '功能,檢測伺服器是否支援指定組件 Function object_install(strclassstring) on error resume next object_install=false dim xtestobj set xtestobj=server.createobject(strclassstring) if -2147221005 <> Err then object_install=true set xtestobj=nothing end function if object_install("Scripting.FileSystemobject")=false then Response.Write "<div style='font-size:12px;color:#333;height:20px;line-height:20px;border:1px solid #DDCF8F;padding:6px;background:#FFFFED;font-family:verdana'>對不起,您的空間不支援FSO組件,請與管理員聯絡!</div>" Response.End end if if object_install("adodb.stream")=false then Response.Write "<div style='font-size:12px;color:#333;height:20px;line-height:20px;border:1px solid #DDCF8F;padding:6px;background:#FFFFED;font-family:verdana'>對不起,您的空間不支援adodb.stream功能,請與管理員聯絡!</div>" Response.End end if '----------------------------------------------------------------------------- '函數名稱:ReadTextFile '作用:利用AdoDb.Stream對象來讀取文字檔 '參數:FileUrl檔案相對路徑,FileCharSet:檔案編碼 Function ReadFromTextFile (FileUrl,FileCharSet)'函數 dim str set stm=server.CreateObject("adodb.stream") stm.Type=2 '指定或返回的資料類型, stm.mode=3 '指定開啟模式,現在為可以讀寫入模式,類似於word的唯讀或鎖定功能 stm.charset=FileCharSet stm.open stm.loadfromfile server.MapPath(FileUrl) str=stm.readtext ReadFromTextFile=str End Function '----------------------------------------------------------------------------- '函數名稱:WriteToTextFile '作用:利用AdoDb.Stream對象來寫入文字檔 sub WriteToTextFile(FileUrl,Str,FileCharSet) '方法 set stm=server.CreateObject("adodb.stream") stm.Type=2 stm.mode=3 stm.charset=FileCharSet stm.open stm.WriteText str stm.SaveToFile server.MapPath(FileUrl),2 stm.flush End sub '----------------------------------------------------------------------------- '功能:自動建立檔案夾 '建立一級或多級目錄,可以建立不存在的根目錄 '參數:要建立的目錄名稱,可以是多級 '返回邏輯值,True成功,False失敗 '建立目錄的根目錄從目前的目錄開始 Function CreateMultiFolder(ByVal CFolder) Dim objFSO,PhCreateFolder,CreateFolderArray,CreateFolder Dim i,ii,CreateFolderSub,PhCreateFolderSub,BlInfo BlInfo = False CreateFolder = CFolder On Error Resume Next Set objFSO = Server.CreateObject("Scripting.FileSystemObject") If Err Then Err.Clear() Exit Function End If CreateFolder = Replace(CreateFolder,"","/") If Left(CreateFolder,1)="/" Then CreateFolder = Right(CreateFolder,Len(CreateFolder)-1) End If If Right(CreateFolder,1)="/" Then CreateFolder = Left(CreateFolder,Len(CreateFolder)-1) End If CreateFolderArray = Split(CreateFolder,"/") For i = 0 to UBound(CreateFolderArray) CreateFolderSub = "" For ii = 0 to i CreateFolderSub = CreateFolderSub & CreateFolderArray(ii) & "/" Next PhCreateFolderSub = Server.MapPath(CreateFolderSub) If Not objFSO.FolderExists(PhCreateFolderSub) Then objFSO.CreateFolder(PhCreateFolderSub) End If Next If Err Then Err.Clear() Else BlInfo = True End If CreateMultiFolder = BlInfo End Function '點擊下載提示 function downloadFile(strFile) strFilename = server.MapPath(strFile) Response.Buffer = True Response.Clear Set s = Server.CreateObject("ADODB.Stream") s.Open s.Type = 1 on error resume next Set fso = Server.CreateObject("Scripting.FileSystemObject") if not fso.FileExists(strFilename) then Response.Write("<h1>Error:</h1>" & strFilename & " does not exist<p>") Response.End end if Set f = fso.GetFile(strFilename) intFilelength = f.size s.LoadFromFile(strFilename) if err then Response.Write("<h1>Error: </h1>" & err.Description & "<p>") Response.End end if Response.AddHeader "Content-Disposition", "attachment; filename=" & f.name Response.AddHeader "Content-Length", intFilelength Response.CharSet = "UTF-8" Response.ContentType = "application/octet-stream" Response.BinaryWrite s.Read Response.Flush s.Close Set s = Nothing End Function '----------------------------------------------------------------------------- If Err Then err.Clear Set conn = Nothing Response.Write "<div style='font-size:12px;color:#333;height:20px;line-height:20px;border:1px solid #DDCF8F;padding:6px;background:#FFFFED;font-family:verdana'>網站異常出錯,請與管理員聯絡,謝謝!</div>" Response.End End If %>產生Word文檔: 複製內容到剪貼簿