'网页中对现有图片实现缩略图显示
'程序编制：薛振山
'时代互联网服务中心
'http://www.9816.net
'邮箱：xzs0001@163.com
Class qswhImg
dim aso
Private Sub Class_Initialize
    set aso=CreateObject("Adodb.Stream")
    aso.Mode=3
    aso.Type=1
    aso.Open
End Sub
Private Sub Class_Terminate
    set aso=nothing
End Sub
Private Function Bin2Str(Bin)
    Dim I, Str
    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
Function getImageSize(filespec)
    dim ret(3)
    aso.LoadFromFile(filespec)
    bFlag=aso.read(3)
    select case hex(binVal(bFlag))
    case "4E5089":
        aso.read(15)
        ret(0)="PNG"
        ret(1)=BinVal2(aso.read(2))
        aso.read(2)
        ret(2)=BinVal2(aso.read(2))
    case "464947":
        aso.read(3)
        ret(0)="GIF"
        ret(1)=BinVal(aso.read(2))
        ret(2)=BinVal(aso.read(2))
    case "535746":
        aso.read(5)
        binData=aso.Read(1)
        sConv=Num2Str(ascb(binData),2 ,8)
        nBits=Str2Num(left(sConv,5),2)
        sConv=mid(sConv,6)
        while(len(sConv) binData=aso.Read(1)
        sConv=sConv&Num2Str(ascb(binData),2 ,8)
        wend
        ret(0)="SWF"
        ret(1)=int(abs(Str2Num(mid(sConv,1*nBits+1,nBits),2)-Str2Num(mid(sConv,0*nBits+1,nBits),2))/20)
        ret(2)=int(abs(Str2Num(mid(sConv,3*nBits+1,nBits),2)-Str2Num(mid(sConv,2*nBits+1,nBits),2))/20)
    case "FFD8FF":
        do
        do: p1=binVal(aso.Read(1)): loop while p1=255 and not aso.EOS
        if p1>191 and p1<196 then exit do else aso.read(binval2(aso.Read(2))-2)
        do:p1=binVal(aso.Read(1)):loop while p1<255 and not aso.EOS
        loop while true
        aso.Read(3)
        ret(0)="JPG"
        ret(2)=binval2(aso.Read(2))
        ret(1)=binval2(aso.Read(2))
    case else:
        if left(Bin2Str(bFlag),2)="BM" then
            aso.Read(15)
            ret(0)="BMP"
            ret(1)=binval(aso.Read(4))
            ret(2)=binval(aso.Read(4))
        else
            ret(0)=""
        end if
    end select
    ret(3)="width=""" & ret(1) &""" height=""" & ret(2) &""""
    getimagesize=ret
End Function
End Class
'显示缩略图
'arr(0) '标示是什么图片，如“jpg”或“gif”等
'f1.name 图片文件名
'arr(1) 宽度（像素）
'arr(2)　高度（像素）
Function picview(filename,wid,hei)
    set qswh=new qswhImg
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set f = fso.GetFolder(server.mappath("./upload/"))
    Set fc = f.Files
    pic=false
    For Each f1 in fc
        if f1.name=filename then '后加
            arr=qswh.getImageSize(f1.path)
            w=arr(1) '实际宽度
            h=arr(2) '实际高度
            pic=true
            exit for
        end if '后加
    Next
    if pic=false then
        response.write"没有这个图片！"
    else
        if w >= wid and h <= hei then wh="width=" & wid '----------------------------宽度大
        if w <= wid and h >= hei then wh="height=" & hei '---------------------------高度大
        if w < wid and h < hei then wh="" '-----------均小
        if w > wid and h > hei then '-------------------------------------------------均大
        '看一下谁大得多
            if (w/wid) >= (h/hei) then wh="width=" & wid '-宽度大的多
            if (w/wid) < (h/hei) then wh="height=" & hei '-高度大的多
        end if
        picview=wh & "," & w
    end if
    Set fc=nothing
    Set f=nothing
    Set fso=nothing
    Set qswh=nothing
End Function

调用方法：Function picview(图片名称,图片宽度,图片高度)，将输入结果加入图片属性代码中即可。