实现上传图片自动压缩图片大小的代码

实现上传图片自动压缩图片大小的代码 <%'on error resume next%> <% dim upload,file,formName,formPath,iCount,filename,fileExt,i,mima,password set upload=new upload_5xSoft '建立上传对象 name=upload.form("name") formPath="../../uploadpic/"&Request.Cookies("login")("userName")&"/"'上传相对目录 userFileName=request.Cookies("login")("userName")'建立企业图片保存目录 CreateFolder(Server.MapPath("../../uploadpic/"&userFileName)) '建立企业文件夹 CreateFolder(Server.MapPath("../../uploadpic/"&userFileName&"/s")) '建立小图存放路径 CreateFolder(Server.MapPath("../../uploadpic/"&userFileName&"/b")) '建立小图存放路径 if right(formPath,1)<>"/" then formPath=formPath&"/" for each formName in upload.file '列出所有上传了的文件 set file=upload.file(formName) '生成一个文件对象 if file.filesize<0 then response.Write("请选择上传的文件") response.end end if if file.filesize>500000 then response.Write("文件不得超过500Kb") response.end end if fileExt=lcase(right(file.filename,4)) if fileEXT<>".gif" and fileEXT<>".jpg" and fileEXT<>".png" then response.Write("只允许上传gif,jPG,png文件!") response.end end if Dim Jpeg FilePath=Server.MapPath("./")'设置上传目录位置 FilePath=Req(FilePath &"/"&formPath) Set Jpeg = Server.CreateObject("Persits.Jpeg") If -2147221005=Err then response.Write("没有ASPJPEG组件请安装") Response.End() End If ranNum=int(900*rnd)+100 filenamett=file.FileName filenamet=year(now)&month(now)&day(now)&hour(now)&minute(now)&second(now)&ranNum &fileExt filename=Req(filepath&filenamet) filesize=file.filesize if file.FileSize>0 then '如果 FileSize > 0 说明有文件数据 file.SaveAs filename '保存文件 else response.redirect "info.asp?info=文件错误!" response.Write("文件错误") response.end end if '图片水印功能开始 Jpeg.Open filename Jpeg.Canvas.Font.Color = &HFFFFFF Jpeg.Canvas.Font.Family = "Arial" 'family设置字体 Jpeg.Canvas.Font.Bold = True '是否设置成粗体 Jpeg.Canvas.Font.Size = 16 '字体大小 Jpeg.Canvas.Font.Quality = 2'输出质量 Jpeg.Canvas.Print Jpeg.width-150, Jpeg.height-23, "WWW.2007LJFW.COM" 'Jpeg.Save filename'需要水印保留这句即可 '图片水印功能结束 set file=nothing Jpeg.Open (filename) '开始变更所有文件扩展名为jpg filenamelen=len(filenamet) filenamelen=filenamelen-4 filenamet1=filenamet filenamet=left(filenamet,filenamelen) filenamet=filenamet&".jpg" '结束文件名变更 '开始判断哪边为长边，以长边进行缩放 imgWidth=Jpeg.OriginalWidth imgHeight=Jpeg.OriginalHeight if imgWidth>=imgHeight and imgWidth>=150 then Jpeg.Width=150 Jpeg.Height=Jpeg.OriginalHeight/(Jpeg.OriginalWidth/150) end if if imgHeight>imgWidth and imgHeight>200 then Jpeg.Height=200 Jpeg.Width=Jpeg.OriginalWidth/(Jpeg.OriginalHeight/200) end if '结束判断 'ImgObj.SaveFile(FilePath & "small_" & filenamet) 'end if 'ImgObj.Free 'Set ImgObj = nothing Jpeg.Sharpen 1, 130 Jpeg.Save (FilePath & "/s/"&filenamet) '写入数据库 yy=year(date) mm=right("00"&month(date),2) dd=right("00"&day(date),2) idate=yy & "-" & mm & "-" & dd & " " xx=right("00"&hour(time),2) ff=right("00"&minute(time),2) mm=right("00"&second(time),2) itime=xx & ":" & ff & ":" & mm itime=idate&itime photourlb=formPath & filenamet1 'if imgwidth<320 and imgheight<240 then photourls=formPath & "s/"&filenamet 'else 'photourls=photourlb 'end if name=upload.form("name") rs.open "SMT_cp",conn_p,1,3 rs.addnew rs("name")=trim(upload.form("name")) rs.update rs.close next set upload=nothing conn.close set conn=nothing conn_p.close set conn_p=nothing response.Redirect("add_products.asp?action=ok") Function Req(Str) If IsEmpty(Str) Then Exit Function Str = Lcase(Str) do A_len=len(Str) Str = Replace(Str,Chr(0),"") Str = Replace(Str,"asp","") Str = Replace(Str,"asa","") Str = Replace(Str,"aspx","") Str = Replace(Str,"cer","") Str = Replace(Str,"cdx","") Str = Replace(Str,"htr","") Str = Replace(Str,"asax","") Str = Replace(Str,"ascx","") Str = Replace(Str,"ashx","") Str = Replace(Str,"asmx","") Str = Replace(Str,"axd","") Str = Replace(Str,"vsdiso","") Str = Replace(Str,"rem","") Str = Replace(Str,"soap","") Str = Replace(Str,"config","") Str = Replace(Str,"cs","") Str = Replace(Str,"csproj","") Str = Replace(Str,"vb","") Str = Replace(Str,"vbproj","") Str = Replace(Str,"webinfo","") Str = Replace(Str,"licx","") Str = Replace(Str,"resx","") Str = Replace(Str,"resou","") Str = Replace(Str,"jsp","") Str = Replace(Str,"php","") Str = Replace(Str,"cgi","") str = Replace(str," ","") str = Replace(str,"%5C","") str = Replace(str,"%2F","") str = Replace(str,"asp","") str = Replace(str,"asa","") str = Replace(str,"cer","") str = Replace(str,"cdx","") str = Replace(str,"mdb","") str = Replace(str,"hrt","") str = Replace(str,"aspx","") str = Replace(str,"php","") str = Replace(str,"jsp","") str = Replace(str,"'","") loop until A_len=len(Str) Req=Str End Function Function CreateFolder(Filepath) Dim fso, f on error resume next Set fso = CreateObject("Scripting.FileSystemObject") if not fso.FolderExists(Filepath) then Set f = fso.CreateFolder(Filepath) set f = Nothing end if set fso = Nothing End Function %>