Download images from the network to the local ASP code

<% @ Language = "VBScript" codePage = "936" %>
<% Option explicit
Class boxinfoimg
'Usage of the transmission class
'Image upload and upload information acquisition class
'Usage:
'Dim imgup
'Set imgup = new boxinfoimg [Source: feitec.com content, reprinted, please specify the source]

'Property:
'Imgup. width' width
'Imgup. height' height
'Imgup. imgsize' size
'Imgup. imgtype' type
'Imgup. imgname' file name
'Imgup. imgname' image file name :"&
'Imgup. filename' file name "&
'Imgup. extname' extension"
'Imgup. diskpath' storage location"
'Imgup. xupath' virtual path"
'Imgup. newurl' saved URL"
'Imgup. savemode' saved URL"[Source: feitec.com content, reprinted, please specify the source]

'Method:
'Imgup. saveimg (fullpath) 'Save the image file

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) 'gets XMLHTTP data
Fsize = clng (lenb (fdata) 'get the data size

If fsize = 0 then
Exit Function
R_write "no valid data is saved", 0
End if

Ados. Write fdata
Ados. Position = 0

Savename = isavename
Savepath = isavepath
Savemode = isavemode

'Write Text object read image width and type

Ados. Position = 0' reset data start position
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

'File type and length/width
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 "wrong URL, please enter accessible URL", 0
Exit Function
End if
Filename = Split (namestr ,"? ") (0)
Ln = Limit Rev (filename ,".")
If ln> 0 then
Prename = left (filename, limit Rev (filename, ".")-1)
Else
Prename = filename
End if
'R _ write filename, 1
'R _ write limit Rev (filename, "."), 1
'R _ write filename, 0
Extname = right (filename, Len (filename)-limit Rev (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
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 "invalid ", 1
exit function
end if
dim tempstr
tempstr = Split (getstrurl, "/")
If tempstr (ubound (tempstr )) = "" Or instr (strurl, "/") = 0 then
r_write "no valid URL specified ", 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> the transfer file bar is not filled! ", 0
End if

Set imgup = new boxinfoimg

If mode = "1" and imgup. imgname = "unknow" then
Call tform ()
Set imgup = nothing
R_write "<br> A valid image URL is not provided in the Transfer File bar! ", 0
End if

Chkinfo = ""
Dim I, teststr, showstr
'Limited format
Select case imgup. imgtype
Case "PNG", "jpg", "BMP", "GIF"
If imgup. width = 0 or imgup. Height = 0 or imgup. imgsize = 0 then
Chkinfo = "<li>" + "the transmitted image data does not exist. Check whether your url is correct"
End if
Case else
Chkinfo = "<li> the transmission format is invalid. The format of image data is" "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' check that the uploaded image data is correct, save
Call tform ()
R_write chkinfo, 0
Else
Server. scripttimeout = 5000
Imgup. saveimg imgup. diskpath
End if
'-------------
R_write "<B >== processing result data ===</B> <br>", 1
R_write "width:" & imgup. Width & "pix", 1
R_write "height:" & imgup. Height & "pix", 1
R_write "Size:" & formatnumber (imgup. imgsize/1024,2,-1) & "kb", 1
R_write "Format:" & imgup. imgtype, 1
R_write "image file name:" & imgup. imgname, 1
R_write "file name:" & imgup. filename, 1
R_write "Extension:" & imgup. extname, 1
R_write "storage location:" & imgup. diskpath, 1
R_write "virtual path:" & imgup. xupath, 1
R_write "saved URL:" & imgup. newurl, 1
Call tform ()
Set imgup = nothing
R_write "------------------------ <br> transfer completed", 0
End sub

Sub tform ()
%>
<Form method = post name = form2 style = "margin: 0px;">
Get URL: <input type = "text" size = 50 name = "getstrurl" value = "http://bbs.dvbbs.net/images/LOGO.GIF"> <br>
Save path: <input type = "text" size = 50 name = "savepath" value = "./"> <br>
Save file name: <input type = "text" size = 50 name = "savename" value = ""> <br>
Save type:
<Input type = "radio" name = "savemode" value = 1 <% if isavemode = "1" or isavemode = "" Then response. write "checked" end if %> Web image
<Input type = "radio" name = "savemode" value = 2 <% if isavemode = "2" then response. Write "checked" end if %> text file
<Input type = "radio" name = "savemode" value = 0 <% if isavemode = "0" then response. Write "checked" end if %> binary data
<Input type = "Submit" value = "Confirm submission">

<HR size = 1>
<%
If getstrurl <> "" then
If isavemode = "2" then
R_write "<button name =" "previews" "Title =" "Page snapshot" "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.html encode (imgup. textstr) & "</textarea>", 1
Else
R_write "End if
End if
%>
</Form>
<HR size = 1>
<Br> If the image is saved as an image, do not add an extension. Automatic Identification is added. If the added extension is invalid, the extension is automatically added.
<Br> If the path of the saved file is null, it is saved in the current path.
<Br> If the file name to be saved is empty, the automatically recognized file name is used.
<Br> Save as any other method. For HTML such as asp 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.doc ument. Write (CODE );
Newwin.doc ument. Close ();
}
Function setsmiley (what)
{
Document. postform. Comment. Value + = "" + What;
Document. postform. Comment. Focus ();
}*/
Function runcode (Num) // run Code 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.doc ument. Write (CODE );
Newwin.doc ument. Close ();
}
// -->
</SCRIPT>
</Head>
<Body>
<%
Dim imgup 'transfer object
Dim getstrurl 'the image or webpage URL to be obtained
Dim isavename' name to be saved
Dim isavepath 'the virtual path to be saved
Dim isavemode: Save mode 1: Image 0: any file
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>