直接保存URL图像或网页到服务器本地的类


            复制代码 代码如下:<% @ LANGUAGE="VBSCRIPT" CODEPAGE="936"%> <% Option Explicit Class BoxInfoImg     '传输类的使用方法     '图象上传和上传信息获取CLASS     '用法:     'dim imgUp     'set imgUp=new BoxInfoImg     '属性:      'imgUp.width    '宽     'imgUp.height    '高     'imgUp.imgSize    '大小     'imgUp.imgType    '类型     'imgUp.imgName    '文件名     'imgUp.imgName '图像文件名:"&     'imgUp.filename '文件名"&     'imgUp.extName '扩展名"     'imgUp.DiskPath '保存位置"     'imgUp.XuPath '虚拟路径"     'imgUp.NewUrl '保存后url"     'imgUp.SaveMode '保存后url"     '方法:     'imgUp.saveImg(fullpath)    '保存图像文件     dim ADOS     dim width,height,imgSize,imgType,imgName,fileName     dim preName,extName     dim SavePath,SaveName,SaveMode     dim DiskPath,XuPath,NewUrl     dim textStr     dim i     Private Sub Class_Initialize         set ADOS=Server.CreateObject("Adodb.Stream")             ADOS.Type=1              ADOS.Mode=3              ADOS.Open              getImageSize     End Sub     Private Sub Class_Terminate         ADOS.close         set ADOS=nothing     End Sub     Public Function getImageSize()              dim ret(3),bFlag,fdata,fsize             fdata=GetWebData(GetStrUrl) '取得XmlHttp数据             fsize=clng(lenb(fdata))        '取得数据尺寸                          if fsize=0 then                  exit function                  R_write "无有效数据保存",0             end if             ADOS.Write fdata                 ADOS.Position=0             SaveName=iSaveName             SavePath=iSavePath             SaveMode=iSaveMode             '写文本对象读取图像长宽和类型             ADOS.Position=0 '重置数据开始位置              bFlag=ADOS.read(3)             if isNull(bFlag) then                  width=0                 height=0                 imgSize=0                 imgType="unknow"                 ret(0)=imgType:ret(1)=width:ret(2)=height:ret(3)=""                 getimagesize=ret                 exit function             end if             '取文件类型和长宽             select case hex(binVal(bFlag))             case "4E5089":                 ADOS.read(15)                 ret(0)="png"                 ret(1)=BinVal2(ADOS.read(2))                 ADOS.read(2)                 ret(2)=BinVal2(ADOS.read(2))             case "464947":                 ADOS.read(3)                 ret(0)="gif"                 ret(1)=BinVal(ADOS.read(2))                 ret(2)=BinVal(ADOS.read(2))             case "FFD8FF":                 dim p1                 do                  do: p1=binVal(ADOS.Read(1)): loop while p1=255 and not ADOS.EOS                 if p1>191 and p1<196 then exit do else ADOS.read(binval2(ADOS.Read(2))-2)                 do:p1=binVal(ADOS.Read(1)):loop while p1<255 and not ADOS.EOS             loop while true                 ADOS.Read(3)                 ret(0)="jpg"                 ret(2)=binval2(ADOS.Read(2))                 ret(1)=binval2(ADOS.Read(2))             case else:                 if left(Bin2Str(bFlag),2)="BM" then                     ADOS.Read(15)                     ret(0)="bmp"                     ret(1)=binval(ADOS.Read(4))                     ret(2)=binval(ADOS.Read(4))                 else                     ret(0)=""                 end if             end select             '             dim tempStr             dim nameStr             dim defaultName             dim ln             tempStr=split(GetStrUrl,"/")             nameStr=tempStr(ubound(tempStr))             if nameStr="" then                 r_write "错误的URL,请输入可访问的URL",0                 exit function             end if             fileName=split(nameStr,"?")(0)             ln=inStrRev(fileName,".")             if ln>0 then                  preName=left(fileName,inStrRev(fileName,".")-1)             else                 preName=fileName             end if             'R_write fileName,1             'R_write inStrRev(fileName,"."),1             'R_write fileName,0             extName=right(fileName,len(fileName)-inStrRev(fileName,"."))             Select case ret(0)             case "png","jpg","bmp","gif","swf"                 width=ret(1)                 height=ret(2)                 imgSize=fsize                 imgType=ret(0)                 imgName=preName&"."&ret(0)             case else                 width=0                 height=0                 imgSize=fsize                 imgName="unknow"                 imgType=".unknow"             end select             if SaveMode="1" then                 defaultName=imgName                 if SaveName="" then                      SaveName=defaultName                 else                     if lcase(right(SaveName,4))<>"."&imgType then                         SaveName=SaveName&"."&imgType                     end if                 end if             else                 defaultName=filename             end if             if SaveName="" then SaveName=defaultName             SavePath=replace(SavePath,"//","/")             if right(SavePath,1)<>"/" then SavePath=SavePath&"/"             if SavePath="" then SavePath="./"                 DiskPath=server.mappath(SavePath&SaveName)                 XuPath=replace(replace(DiskPath,server.mappath("/"),""),"\","/")             NewUrl="http://"&Request.ServerVariables("SERVER_NAME")&XuPath             getimagesize=ret     End Function     Public function SaveImg(FullPath)         SaveImg=false         if SaveMode="1" then             if trim(fullpath)="" or _                 width=0 or _                  height=0 or _                 imgSize=0 or _                 imgType=".unknow" then exit function end if         end if         ADOS.Position=0         if SaveMode="2" then             ADOS.Type=2             ADOS.Charset ="gb2312"             ADOS.SaveToFile FullPath,2             textStr=ADOS.readtext()         else             ADOS.SaveToFile FullPath,2         end if         SaveImg=true     End function     Private Function Bin2Str(Bin)         Dim I,Str,clow         For I=1 to LenB(Bin)             clow=MidB(Bin,I,1)         if ASCB(clow)<128 then             Str = Str & Chr(ASCB(clow))         else             I=I+1             if I <= LenB(Bin) then Str = Str & Chr(ASCW(MidB(Bin,I,1)&clow))         end if         Next              Bin2Str = Str     End Function     Private Function Num2Str(num,base,lens)         dim ret:ret = ""         while(num>=base)             ret=(num mod base) & ret             num=(num - num mod base)/base         wend             Num2Str = right(string(lens,"0") & num & ret,lens)     End Function     Private Function Str2Num(str,base)         dim ret:ret = 0         for i=1 to len(str)             ret = ret *base + cint(mid(str,i,1))         next             Str2Num=ret     End Function     Private Function BinVal(bin)         dim ret:ret = 0         for i = lenb(bin) to 1 step -1             ret = ret *256 + ascb(midb(bin,i,1))         next             BinVal=ret     End Function     Private Function BinVal2(bin)         dim ret:ret = 0         for i = 1 to lenb(bin)             ret = ret *256 + ascb(midb(bin,i,1))         next             BinVal2=ret     End Function     Private    Function GetWebData(byval StrUrl)         if StrUrl="" then              r_write "无效",1             exit function         end if         dim tempStr         tempStr=split(GetStrUrl,"/")         if tempStr(ubound(tempStr))="" or inStr(StrUrl,"/")=0 then             R_Write "未指定有效的URL",0             exit function         end if         dim Retrieval         Set Retrieval = Server.CreateObject("Microsoft.XMLHTTP")         With Retrieval         .Open "Get", StrUrl, False, "", ""         .Send         GetWebData =.ResponseBody         End With         Set Retrieval = Nothing     End Function             End Class %> <% SUB saveUpload(GetUrl,SavePath,SaveName,mode)     dim chkInfo     if GetUrl="" then          call tform()         R_Write "<br>传输文件栏没有填写!",0     end if     set imgUp=new BoxInfoImg     if mode="1" and imgUp.imgName="unknow" then         call tform()         set imgUp=nothing         R_Write "<br>传输文件栏没有填写有效的图像URL!",0     end if     chkInfo=""     dim i,testStr,showStr     '限定格式     select case imgUp.imgType     case "png","jpg","bmp","gif"         if imgUp.width=0 or imgUp.height=0 or imgUp.imgSize=0 then              chkInfo="<li>"+"传输图像数据不存在,请确定你的URL是否正确"         end if     case else          chkInfo="<li>无效的传输格式,允许图像数据格式为 ""png"",""jpg"",""bmp"",""gif""</li>"     end select     'R_Write SavePath,1     'R_Write mode,1     'R_Write imgUp.imgName,1     'R_Write imgUp.filename,1     'R_Write "SaveName="&SaveName,1     if mode="1" and chkInfo<>"" then '检查上传图像数据合格后,则保存之             call tform()             R_Write chkInfo,0     else         Server.ScriptTimeOut=5000         imgUp.saveImg imgUp.DiskPath          end if '-------------             R_write "<b>===处理结果部分资料===</b><br>",1             R_write "　　宽:"&imgUp.width&" pix",1             R_write "　　高:"&imgUp.height&" pix",1             R_write "　大小:"&formatnumber(imgUp.imgSize/1024,2,-1)&" KB",1             R_write "　格式:"&imgUp.imgType,1             R_write "图像文件名:"&imgUp.imgName,1             R_write "文件名:"&imgUp.filename,1             R_write "扩展名:"&imgUp.extName,1             R_write "保存位置:"&imgUp.DiskPath,1             R_write "虚拟路径:"&imgUp.XuPath,1             R_write "保存后url:"&imgUp.NewUrl,1         call tform()         set imgUp=nothing              R_write "------------------------<br>传输完毕",0 End SUB SUB tform() %> <FORM METHOD=POST name=form2 style="margin:0px;"> 　获取 URL：<INPUT TYPE="text" size=50 NAME="GetStrUrl" value="http://www.blueidea.com/img/common/logo.gif"><br> 　保存路径：<INPUT TYPE="text" size=50 NAME="SavePath" value="./"><br> 保存文件名：<INPUT TYPE="text" size=50 NAME="SaveName" value=""><br> 　保存类型： <INPUT TYPE="radio" NAME="SaveMode" value=1 <%if iSaveMode="1" or iSaveMode="" then response.write "checked" end if%>> Web图像  <INPUT TYPE="radio" NAME="SaveMode" value=2 <%if iSaveMode="2" then response.write "checked" end if%>> 文本文件 <INPUT TYPE="radio" NAME="SaveMode" value=0 <%if iSaveMode="0" then response.write "checked" end if%>> 二进制数据    <INPUT TYPE="submit" value="确定提交"> <hr size=1> <% if GetStrUrl<>"" then     if iSaveMode="2" then         R_write "<button name=""Previews"" title=""页面快照"" onclick=""runCode(0);"">Run this code</button>",1         R_write "<textarea cols=100 name=content rows=10 style="" width:90%;fixed;word-break:break-all;"">"&server.htmlencode(imgUp.textStr)&"</textarea>",1     else          R_write "<img src="""&imgUp.XuPath&"?"&timer()&""" width="&imgUp.width&" height="&imgUp.height&" alt="&imgUp.imgName&">",1     end if end if %> </FORM> <hr size=1> <br>如果保存为图像，不要加扩展名，自动识别加上，如果加的扩展名不合也回自动加上 <br>保存文件路径为空则保存在当前路径 <br>保存文件名为空则使用自动识别取得的文件名 <br>保存为其他任意方式，对asp html 等为取得发送结果的Html <%End SUB Sub R_write(str,num)     dim istr:istr=str     dim inum:inum=num     response.write str&"<br>"     if inum=0 then response.end end sub '=================调用过程 Execute======================== %> <!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN"> <HTML> <HEAD> <TITLE> New Document </TITLE> <META NAME="Generator" CONTENT="EditPlus"> <META NAME="Author" CONTENT="V37"> <META NAME="Keywords" CONTENT=""> <META NAME="Description" CONTENT=""> <SCRIPT LANGUAGE="JavaScript"> <!-- /*function runCode()  { var code=event.srcElement.parentElement.children[0].value; var newwin=window.open('','','');  newwin.opener = null  newwin.document.write(code); newwin.document.close(); } function setsmiley(what)  {  document.PostForm.comment.value += " "+what;  document.PostForm.comment.focus();  } */     function runCode(num) //运行代码HTML         {          // var code=event.srcElement.parentElement.children[0].value;          if(num==1){var code=window.form2.code.innerText;}          if(num==0){var code=window.form2.content.innerText;}          var newwin=window.open('','','');          newwin.opener = null          newwin.document.write(code);          newwin.document.close();         } //--> </SCRIPT> </HEAD> <BODY> <% dim imgUp        '传输对象 dim GetStrUrl    '要获取的图像或网页URL dim iSaveName    '要保存的名字 dim iSavePath    '要保存的虚拟路径 dim iSaveMode    '保存的模式 1 为图像 0 为任意文件     iSavePath=trim(request.form("SavePath"))     iSaveName=trim(request.form("SaveName"))     GetStrUrl=trim(request.form("GetStrUrl"))     iSaveMode=trim(request.form("SaveMode")) if GetStrUrl<>"" then     CALL saveUpload(GetStrUrl,iSavePath,iSaveName,iSaveMode)     call tform() else     call tform() end if %> </BODY> </HTML>