保存WEB图像或页面到本地的类 - TOMMYHU - 专注互联网开发及运营技术,提供相关资料及软件下载,奇趣网络时事评论!
Mar 9

保存WEB图像或页面到本地的类 不指定

tommyhu , 14:06 , ASP , Comments(0) , Trackbacks(0) , Reads(8225) , Via Original Large | Medium | Small
<% @ 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%>> 二进制数据
&nbsp;&nbsp;&nbsp;<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>

'将上面代码保存问任一个扩展名是 asp的文件,如saveXMLHTTP.asp即可运行

'=========调用方法===========
'注意该部分的代码均不能改变变量命名,与类里去属性是相关的

dim imgUp '传输对象
dim GetStrUrl '要获取的图像或网页URL
dim iSaveName '要保存的名字
dim iSavePath '要保存的虚拟路径
dim iSaveMode '保存的模式 1 为图像 0 为任意文件
iSavePath="./temp/" 可以为 "" 不输入
iSaveName="myimgf" 可以为 "" 不输入
GetStrUrl="http://www.blueidea.com/img/common/logo.gif"
'保存模式 "1" 图像 "2" 文本 "0" 二进制 注意是字符串型的
iSaveMode=trim(request.form("SaveMode"))  
'调用函数
CALL saveUpload(GetStrUrl,iSavePath,iSaveName,iSaveMode)
▲返回顶部

Add a comment

Nickname

emotemotemotemotemotemotemotemotemotemotemotemotemotemotemotemot