'///////////////////////////////////////////////
'VBS相册生成脚本，使用方法：将此文件放在sendto目录中（在运行中输入直接sendto，就可以打开），然后在有图片的文件夹上点右键，选择发送到，等一下，就OK了。
'海娃 http://www.doing8.com
'更新日期:2006-3-19
'///////////////////////////////////////////////
Set ArgObj = WScript.Arguments
Set fsoBrowse = CreateObject("Scripting.FileSystemObject")
dim cpath,imgw,imgh,pagesize,wn,hn,pagetitle,filenamestart,firstpage
cpath=ArgObj(0)'传递路径
dim StartRun
StartRun = msgbox("确定生成吗？",1,"网页相册生成")
if StartRun=1 then
CreatPageHtml(FileInofList(cpath))
end if
function FileInofList(cpath)
ON ERROR RESUME NEXT
dim FileNameListStr
FileNameListStr=""
filesize = 0
if fsoBrowse.FolderExists(cpath)then
Set theFolder=fsoBrowse.GetFolder(cpath)
Set theFiles=theFolder.Files
For Each x In theFiles
if right(lcase(x.name),4) = ".gif" or right(lcase(x.name),4) = ".png" or right(lcase(x.name),4) = ".jpg" then
if x.Size>0 then
set qswh=new qswhImg
arr=qswh.getimagesize(cpath & "\" & x.name)'取得图片的扩展名，高宽信息
dim imgext,imgWidth,imgheight
imgext = arr(0)
imgWidth = arr(1)
imgheight = arr(2)
if lcase(imgext) = "gif" or lcase(imgext) = "jpg" or lcase(imgext) = "png" then
FileNameListStr = FileNameListStr & x.name & "|"& x.Size &"|"& imgWidth & "|" & imgheight &"***"
end if
end if
end if
next
end if
set fsoBrowse = nothing
if len(FileNameListStr)>3 then
FileNameListStr = left(FileNameListStr,len(FileNameListStr)-3)
end if
FileInofList = FileNameListStr
if err<>0 then
msgbox "FileInofList 出错了:" & err.description
err.clear
end if
end function
sub CreatPageHtml(ListStr)
ON ERROR RESUME NEXT
dim filenamearr,filenamenum,outstr
filenamearr = split(ListStr,"***")
filenamenum = ubound(filenamearr)
outstr = ""
for a = 0 to filenamenum
thisstrarr = split(filenamearr(a),"|")
dim w,h
w = thisstrarr(2)
h = thisstrarr(3)
outstr = outstr & "" & vbnewline
outstr = outstr & "
" & vbnewline
'outstr = outstr & "
" & vbnewline
outstr = outstr & "
"& pagetitle &"
" & vbNewLine
tmphtml = tmphtml & "" & vbNewLine
tmphtml = tmphtml & outstr & vbNewLine
tmphtml = tmphtml & "
" & vbNewLine
tmphtml = tmphtml & "" & vbNewLine
tmphtml = tmphtml & info & vbNewLine
tmphtml = tmphtml & "" & vbNewLine
tmphtml = tmphtml & "" & vbNewLine
dim htmlstr
htmlstr = tmphtml
Set fso = CreateObject("Scripting.FileSystemObject")
Set fout = fso.CreateTextFile(cpath&name,true,false)
fout.WriteLine htmlstr
fout.close
set fso = nothing
if err<>0 then
msgbox "creatfile 出错了:" & err.description
err.clear
end if
end sub
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)
'qiushuiwuhen (2002-8-12)
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)
'qiushuiwuhen (2002-8-12)
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)
'qiushuiwuhen (2002-8-12)
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)
'qiushuiwuhen (2002-8-12)
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)
'qiushuiwuhen (2002-9-3)
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)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