ASP实现上传图片自动 压缩图片大小 留存待修改

<!-- #include file="conn.asp" -->
<!--#include file="upload.inc"-->
<%'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
%>