將網路上的圖片下載到本地ASP代碼

<% @ LANGUAGE="VBSCRIPT" CODEPAGE="936"%>
    <%Option Explicit
    Class BoxInfoImg
    '傳輸類的使用方法
    '圖象上傳和上傳資訊擷取CLASS
    '用法:
    'dim imgUp
    'set imgUp=new BoxInfoImg [來源：飛騰設計網www.feitec.com內容，轉載請註明出處]

    '屬性:
    '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" [來源：飛騰設計網www.feitec.com內容，轉載請註明出處]

    '方法:
    '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
    d 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)
    dp1=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://bbs.dvbbs.net/images/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=***********('','','');
    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>