<% Option Explicit Response.Buffer = True Server.ScriptTimeOut = 9999999 %> <% '限制从外部非法提交 If Instr(Request.ServerVariables("http_referer"),"http://" & Request.Servervariables("host") ) < 1 Then Response.Write "处理 URL 时服务器上出错!请与管理员联系..." Response.End End If Const G_FS_FSO = "Scripting.FileSystemObject" 'FSO组件名称 '--------------------------------------------- Dim AllowFileType AllowFileType = "htm" Dim AllowFileSize AllowFileSize = 10240 Dim Create_DateCatalog Create_DateCatalog = True '是否开启创建日期目录 '--------------------------------------------- Dim AutoReName,UpFileObj,FileObject,FormName,FileName,FileExtStr,strFileName Dim Fso,SavePath,AutoSavePath,AppearErr,ClueOn_Msg,StrJs Dim SameFileTF,No_UpFileTF,RealityPath '--------------------------------------------- SavePath = "/" '保存文件目录 If Right(SavePath,1) <> "/" Then SavePath = SavePath & "/" End If Set UpFileObj = New UpFile_Class UpFileObj.GetData(10240000) AutoReName = Trim(UpFileObj.Form("AutoRename")) '是否自动重命名文件 ClueOn_Msg = "" No_UpFileTF = True AppearErr = False If IsObjInstalled(G_FS_FSO) = True Then '------------------------------------------------------------------------------ Set Fso = Server.CreateObject(G_FS_FSO) '-------------------------------------------------------------------------- For Each FormName in UpFileObj.File '列出所有上传了的文件 Set FileObject = UpFileObj.File(FormName) '生成一个文件对象 SameFileTF = False FileName = FileObject.FileName If NoIiiegalStr(FileName) = False Then ClueOn_Msg = "文件：上传被禁止!" AppearErr = True End If FileExtStr = FileObject.FileExt If FileObject.FileSize > 1 Then '如果有文件上传 '---------------------------------------------------------------------- If Fso.FolderExists(Server.MapPath(SavePath)) = True Then '检测目录是否存在 If Create_DateCatalog = True Then '如果开启了自动创建日期目录 AutoSavePath = Year(Now()) & Right("0" & Month(Now()),2) & "/" SavePath = SavePath & AutoSavePath If Not Fso.FolderExists(Server.MapPath(SavePath)) Then '如不存在目录则建立 Fso.CreateFolder Server.MapPath(SavePath) End If End If Else ClueOn_Msg = "目录不存在,无法上传文件!" AppearErr = True End If RealityPath = Server.MapPath(SavePath) & "\" '转换虚拟路径为实际路径 '---------------------------------------------------------------------- No_UpFileTF = False If FileObject.FileSize > Clng(AllowFileSize)*1024 Then ClueOn_Msg = FileName & "文件超过了限制!\n\n最大只能上传" & AllowFileSize & "K的文件" AppearErr = True End If If AutoRename = "2" Then '如果不是自动从命名文件 If Fso.FileExists(RealityPath & FileName) = True Then ClueOn_Msg = "文件:存在同名文件" AppearErr = True Else SameFileTF = False End If Else SameFileTF = True End If If CheckFileType(AllowFileType,FileExtStr) = False Then ClueOn_Msg = "此文件不允许上传!\n\n允许上传文件类型有"& AllowFileType &"" AppearErr = True End If StrJs = "" Response.Write strJS Response.End Else Response.Write( "请选择你要上传的文件！") Response.End End If Next Set FileObject = Nothing Set Fso = Nothing Else Response.Write "上传功能需要FSO组件支持,请检查该组件是否安装正确!" Response.End End If Set UpFileObj = Nothing '//验证上传文件的合法性 Function CheckFileType(AllowExtStr,FileExtName) Dim i,AllowArray,LenTmp LenTmp = Len(FileExtName) AllowArray = Split(AllowExtStr,"|") FileExtName = DealExtName(Trim(LCase(FileExtName))) CheckFileType = False For i = LBound(AllowArray) to UBound(AllowArray) If LCase(AllowArray(i)) = LCase(FileExtName) Then CheckFileType = True End If Next If FileExtName = "asp" or FileExtName = "asa" or FileExtName = "aspx" or FileExtName = "cer" or FileExtName = "php" or FileExtName = "cdx" or FileExtName = "htr" or FileExtName = "exe" Then CheckFileType = False Else If LenTmp <> Len(FileExtName) Then CheckFileType = False End If End If End Function '//检查文件名格式 Function NoIiiegalStr(Byval FileNameStr) Dim Str_Len,Str_Pos Str_Len = Len(FileNameStr) Str_Pos = InStr(FileNameStr,Chr(0)) If Str_Pos = 0 or Str_Pos = Str_Len then NoIiiegalStr = True Else NoIiiegalStr = False End If End function '//替换掉禁止的文件类型 Function DealExtName(Byval UpFileExt) If IsEmpty(UpFileExt) Then Exit Function DealExtName = Lcase(UpFileExt) DealExtName = Replace(DealExtName,Chr(0),"") DealExtName = Replace(DealExtName," ","") DealExtName = Replace(DealExtName,"　","") DealExtName = Replace(DealExtName,Chr(255),"") DealExtName = Replace(DealExtName,".","") DealExtName = Replace(DealExtName,"'","") DealExtName = Replace(DealExtName,"asp","") DealExtName = Replace(DealExtName,"asa","") DealExtName = Replace(DealExtName,"aspx","") DealExtName = Replace(DealExtName,"cer","") DealExtName = Replace(DealExtName,"cdx","") DealExtName = Replace(DealExtName,"htr","") DealExtName = Replace(DealExtName,"php","") DealExtName = Replace(DealExtName,"exe","") End Function '//如果不开启自动命名,则执行替换 '//替换非法文件为自定义字符串 Function ReplaceExt(Byval ExtStr,Byval RepExt) If IsEmpty(ExtStr) or IsEmpty(RepExt) Then Exit Function ReplaceExt = Lcase(ExtStr) ReplaceExt = Replace(ReplaceExt,Chr(0),"") ReplaceExt = Replace(ReplaceExt," ","") ReplaceExt = Replace(ReplaceExt,"　","") ReplaceExt = Replace(ReplaceExt,Chr(255),"") ReplaceExt = Replace(ReplaceExt,"'","") ReplaceExt = Replace(Replace(ReplaceExt,"asp",RepExt),".asp","sp" & RepExt) ReplaceExt = Replace(Replace(ReplaceExt,"asa",RepExt),".asa","sa" & RepExt) ReplaceExt = Replace(Replace(ReplaceExt,"aspx",RepExt),".aspx","spx" & RepExt) ReplaceExt = Replace(Replace(ReplaceExt,"cer",RepExt),".cer","er" & RepExt) ReplaceExt = Replace(Replace(ReplaceExt,"cdx",RepExt),".cdx","dx" & RepExt) ReplaceExt = Replace(Replace(ReplaceExt,"htr",RepExt),".htr","tr" & RepExt) ReplaceExt = Replace(Replace(ReplaceExt,"php",RepExt),".php","hp" & RepExt) ReplaceExt = Replace(Replace(ReplaceExt,"exe",RepExt),".exe","xe" & RepExt) End Function '//产生一个日期字符串 Function DateStr() Dim iYear,iMonth,iDay,iHour,iMinute,iScond iYear = Year(Now) iMonth = Month(Now) iDay = Day(Now) iHour = CStr(Hour(Now())) If Len(iHour) = 1 Then iHour = "0" & iHour End If iMinute = CStr(Minute(Now())) If Len(iMinute) = 1 Then iMinute = "0" & iMinute End If iScond = CStr(Second(Now())) If Len(iScond) = 1 Then iScond = "0" & iScond End If DateStr = iYear & iMonth & iDay & iHour & iMinute & iScond End Function '//生成指定位数的字符 Function rndStr(strLong) Dim tempStr Randomize Do while Len(rndStr) < strLong tempStr = CStr(Chr((57-48)*rnd+48)) rndStr = rndStr & tempStr Loop rndStr = rndStr End Function '//检查组件是否安装 Function IsObjInstalled(ByVal strClassString) Dim xTestObj,ClsString On Error Resume Next IsObjInstalled = False ClsString = strClassString Err = 0 Set xTestObj = Server.CreateObject(ClsString) If Err = 0 Then IsObjInstalled = True If Err = -2147352567 Then IsObjInstalled = True Set xTestObj = Nothing Err = 0 Exit Function End Function %>