利用VBScript及ADODB.Steam获取部分格式图象长宽

Function Bytes2bStr(vin)
if lenb(vin) =0 then
     Bytes2bStr = ""
     exit function
end if
''二进制转换为字符串
 Dim BytesStream,StringReturn
 Set BytesStream = Server.CreateObject("ADODB.Stream")
 BytesStream.Type = 2
 BytesStream.Open
 BytesStream.WriteText vin
 BytesStream.Position = 0
 BytesStream.Charset = "gb2312"
 BytesStream.Position = 2
 StringReturn = BytesStream.ReadText
 BytesStream.close
 Set BytesStream = Nothing
 Bytes2bStr = StringReturn
End Function

Function BinVal(bin)
     Dim i
     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

Function BinVal2(bin)
     Dim i
     Dim ret:ret = 0
     for i = 1 to lenb(bin)
           ret = ret *256 + ascb(midb(bin,i,1))
     next
     BinVal2 = ret
End Function

Function getImageWH(fdata)
'一个实参fdata,二进制图象数据(至于怎么读取图象的二进制数据就不用说了吧-_-!)
'返回值为一个数组,3个元素,分别为图片格式.长.宽

dim ret(2),bFlag,fsize,ADOS

fsize=clng(lenb(fdata)) '取得数据尺寸

if fsize=0 then      Exit Function

Set ADOS = Server.CreateObject("ADODB.Stream")
ADOS.Type = 1
ADOS.Mode = 3
ADOS.Open

ADOS.Write fdata
ADOS.Position = 0

'写文本对象读取图像长宽和类型

ADOS.Position = 0 '重置数据开始位置
bFlag = ADOS.read(3)

if isNull(bFlag) then
     ret(0) = "unknow"
     ret(1) = 0
     ret(2) = 0
     getimagewh = 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(Bytes2bStr(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
ADOS.Close
Set ADOS = Nothing
end select

Select case ret(0)
case "png","jpg","bmp","gif"
     ret(1) = ret(1)
     ret(2) = ret(2)
     ret(0) = ret(0)
case else
     ret(1) = 0
     ret(2) = 0
     ret(0) = "unknow"
end select

getimageWH = ret
End Function

Function GetWebData(StrUrl)
'获取INTERNET上的图片二进制数据
     On Error Resume Next
     if StrUrl="" then
           GetWebData = ""
           exit function
     end if
     dim tempStr
     tempStr=split(StrUrl,"/")
     if tempStr(ubound(tempStr))="" or inStr(StrUrl,"/")=0 then
           GetWebData = ""
           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
     If Err.Number <> 0 Then Err.Clear

End Function

本文地址：http://com.8s8s.com/it/it42869.htm