復制代碼 代碼如下:
<% @ 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>
