VBS相册生成脚本[
(编辑：jimmy 日期: 2024/11/15 浏览：3 次 )
此脚本的功能为将一个目录中的jpg,gif,png格式的图片生成Html相册，页面上的图像只是改变显示大小，并没有生成缩略图。
用到的技术：Scripting.FileSystemObject，Adodb.Stream。其中得到图片长宽用了秋水无恨的Adodb.Stream取得图像的高宽
复制代码 代码如下:
'///////////////////////////////////////////////
'VBS相册生成脚本，使用方法：将此文件放在sendto目录中（在运行中输入直接sendto，就可以打开），然后在有图片的文件夹上点右键，选择发送到，等一下，就OK了。
'海娃 http://www.51windows.Net
'更新日期:2004-12-30
'///////////////////////////////////////////////
Set ArgObj = WScript.Arguments
Set fsoBrowse = CreateObject("Scripting.FileSystemObject")
dim cpath,imgw,imgh,pagesize,wn,hn,pagetitle,filenamestart,firstpage
cpath=ArgObj(0)'传递路径
imgw = 240
imgh = 180
wn = 3
hn = 3
pagetitle = "图片展示 - 51windows.Net"
filenamestart = "Page_"
firstpage = "index.htm"
pagetitle2 = inputbox("请输入页面标题","请输入页面标题",pagetitle)
if isempty(pagetitle2) = false and len(pagetitle2) > 1 then
pagetitle = pagetitle2
end if
filenamestart2 = inputbox("请输入文件名前缀","请输入文件名前缀",filenamestart)
if isempty(filenamestart2) = false and len(filenamestart2) > 1 then
filenamestart = filenamestart2
end if
firstpage2 = inputbox("请输入第一页的文件名，点取消按序号生成","请输入第一页的文件名",firstpage)
if isempty(firstpage2) = false and len(filenamestart2) > 1 then
firstpage = firstpage2
else
firstpage = ""
end if
if len(firstpage) > 0 and (right(lcase(firstpage),4)<>".htm" and right(lcase(firstpage),5)<>".html") then
firstpage = firstpage & ".htm"
end if
imgw2 = inputbox("请输入小图的宽度","请输入小图的宽度",imgw)
if isnumeric(imgw2) and isempty(imgw2) = false then
imgw = imgw2
end if
imgh2 = inputbox("请输入小图的高度","请输入小图的高度",imgh)
if isnumeric(imgh2) and isempty(imgh2) = false then
imgh = imgh2
end if
wn2 = inputbox("请输入每行的图像数","请输入每行的图像数",wn)
if isnumeric(wn2) and isempty(wn2) = false then
wn = wn2
end if
hn2 = inputbox("请输入行数","请输入行数",hn)
if isnumeric(hn2) and isempty(hn2) = false then
hn = hn2
end if
dim info
info = "<!-- 本页面有 VBScript 相册生成脚本生成，http://www.51windows.Net -->"
pagesize = wn*hn
dim message
message = ""
message = message & "文件路径：" & chr(9) & cpath & vbnewline
message = message & "页面标题：" & chr(9) & pagetitle & vbnewline
message = message & "文件名前缀：" & chr(9) & filenamestart & vbnewline
message = message & "首页文件名：" & chr(9) & firstpage & vbnewline
message = message & "小图的宽度：" & chr(9) & imgw & vbnewline
message = message & "小图的高度" & chr(9) & imgh & vbnewline
message = message & "每行的图像数：" & chr(9) & wn & vbnewline
message = message & "行数：" & chr(9) & chr(9) & hn & vbnewline
message = message & vbnewline & "确定生成吗？" & vbnewline
dim StartRun
StartRun = msgbox(message,1,"VBS相册生成脚本")
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
thisstr = filenamearr(a)
thisstrarr = split(thisstr,"|")
if ubound(thisstrarr) = 3 then
dim w,h
w = thisstrarr(2)
h = thisstrarr(3)
okw = imgw
okh = imgh
if (w/h)>(imgw/imgh) then
if int(w)>=int(imgw) then
okw = imgw
okh = formatnumber(h*imgw/w,0)
else
okw = w
okh = h
end if
else
if int(h)>=int(imgh) then
okh = imgh
okw = formatnumber(w*imgh/h,0)
else
okw = w
okh = h
end if
end if
dim vspace
vspace = 0
if int(imgh)>int(okh) then
vspace = formatnumber((imgh-okh)/2,0)-3
end if
if int(vspace)<1 then
vspace = 0
end if
outstr = outstr & "<div class=""oneDiv"">" & vbnewline
outstr = outstr & " <div class=""ImgDiv""><a href="""& thisstrarr(0) &""" onclick=""ShowImg(this.href,"& w &","& h &");return false""><img border=""0"" title="""& thisstrarr(0) &"("& thisstrarr(1) &" byte)"" alt="""& thisstrarr(0) &""" src="/UploadFiles/2021-04-08/"> outstr = outstr & " <div class=""TextDiv""><a href="""& thisstrarr(0) &""" onclick=""ShowImg(this.href,"& w &","& h &");return false"">"& thisstrarr(0) &"</a></div>" & vbnewline
outstr = outstr & "</div>" & vbnewline
end if
if ((a+1) mod pagesize = 0) or (a = filenamenum) then
dim n1,nn
n1 = formatnumber(((a+1)/pagesize+0.49999),0)
nn = formatnumber((filenamenum+1)/pagesize+0.49999,0)
pagestr = "<div>"
if int(pagesize) = 1 then
nn = int(nn)+1
end if
for b = 1 to nn
bb = addzero(b,nn)
if int(b)<>int(n1) then
if int(b) = 1 and firstpage<>"" then
pagestr = pagestr & " <a href="""& firstpage &""">"& bb &"</a> "
else
pagestr = pagestr & " <a href="""& filenamestart &""& bb &".htm"">"& bb &"</a> "
end if
else
pagestr = pagestr & " "& bb &" "
end if
next
pagestr = pagestr & "</div><div align=""center"">"
if int(n1) = 1 then
pagestr = pagestr & "<span id=""PrevLink"">[ Prev ]</span>"
else
if int(n1) = 2 and firstpage<>"" then
pagestr = pagestr & "[ <a id=""PrevLink"" href="""& firstpage &""">Prev</a> ]"
else
pagestr = pagestr & "[ <a id=""PrevLink"" href="""& filenamestart &""& addzero((n1-1),nn) &".htm"">Prev</a> ]"
end if
end if
if int(n1) = int(nn) then
pagestr = pagestr & "<span id=""NextLink"">[ Next ]</span>"
else
pagestr = pagestr & "[ <a id=""NextLink"" href="""& filenamestart &""& addzero((n1+1),nn) &".htm"">Next</a> ]"
end if
if int(nn) > 1 then
pagestr = "<div class=""pageDiv"">"& pagestr & "</div></div>"
else
pagestr = ""
end if
if int(n1) = 1 and firstpage<>"" then
creatfile outstr,pagestr,"/"& firstpage
else
creatfile outstr,pagestr,"/"& filenamestart &""& addzero(n1,nn) &".htm"
end if
outstr = ""
end if
next
if err=0 then
msgbox "文件已生成"
else
msgbox "CreatPageHtml 出错了:" & err.description
err.clear
end if
end sub
function addzero(num1,numn)
addzero = right("00000000"&num1,len(numn))
end function
function formattitle(str)
str1 = str
str1 = replace(str1,"""",""")
formattitle = str1
end function
sub creatfile(outstr,pagestr,name)
ON ERROR RESUME NEXT
dim tmphtml
tmphtml = tmphtml & "<html>" & vbNewLine
tmphtml = tmphtml & "<head>" & vbNewLine
tmphtml = tmphtml & "<meta http-equiv=""Content-Type"" content=""text/html; charset=gb2312"">" & vbNewLine
tmphtml = tmphtml & "<meta name=""GENERATOR"" content=""Microsoft FrontPage 4.0"">" & vbNewLine
tmphtml = tmphtml & "<meta name=""ProgId"" content=""FrontPage.Editor.Document"">" & vbNewLine
tmphtml = tmphtml & "<title>"& pagetitle &"</title>" & vbNewLine
tmphtml = tmphtml & "<style>" & vbNewLine
tmphtml = tmphtml & "<!--" & vbNewLine
tmphtml = tmphtml & "body {margin:0px;}" & vbNewLine
tmphtml = tmphtml & ".TitleDiv {margin:2px;padding:2px;display:block;font-size:18pt;font-family:Verdana;width:"& (int(imgw)+20)*wn &"px;}" & vbNewLine
tmphtml = tmphtml & ".pageDiv {margin:2px;padding:2px;display:block;font-size:11pt;font-family:Verdana;word-break : break-all;width:"& (int(imgw)+20)*wn &"px;}" & vbNewLine
tmphtml = tmphtml & "a {word-break : break-all;}" & vbNewLine
tmphtml = tmphtml & ".FullDiv {margin:0px;padding:0px;width:"& (int(imgw)+20)*wn &"px;}" & vbNewLine
tmphtml = tmphtml & ".oneDiv {background-color: #FFFFFF; border: 0px solid #F2F2F2; padding: px;margin:2px;width:"& (int(imgw)+12) &"px;height:"& (int(imgh)+30) &"px;float:left;}" & vbNewLine
tmphtml = tmphtml & ".ImgDiv {background-color: #F2F2F2; border: 1px solid #999999; padding: 2px;margin:2px;width:"& (int(imgw)+8) &"px;height:"& (int(imgh)+4) &"px;overflow:hidden;text-align:center;}" & vbNewLine
tmphtml = tmphtml & ".TextDiv {background-color: #F2F2F2; border: 1px solid #999999; padding: 2px;margin:2px;width:"& (int(imgw)+8) &"px;height:20px;overflow:hidden;text-align:center;font-size:9pt;font-family:Verdana;}" & vbNewLine
tmphtml = tmphtml & "-->" & vbNewLine
tmphtml = tmphtml & "</style>" & vbNewLine
tmphtml = tmphtml & "</head>" & vbNewLine
tmphtml = tmphtml & "<body onkeydown=""if(event.keyCode==37){if(PrevLink.href){window.open(PrevLink.href,'_self','')}}else if(event.keyCode==39){if(NextLink.href){window.open(NextLink.href,'_self','')}}"">" & vbNewLine
tmphtml = tmphtml & "<SCRIPT LANGUAGE=""JavaScript"">" & vbNewLine
tmphtml = tmphtml & "<!--" & vbNewLine
tmphtml = tmphtml & "function ShowImg(url,w,h)" & vbNewLine
tmphtml = tmphtml & "{" & vbNewLine
tmphtml = tmphtml & "newwin = window.open(""about:blank"","""",""width=""+(w-3)+"",height=""+(h-3)+"",left=""+(window.screen.width-w)/2+"",top=""+(window.screen.height-h)/2+"""")" & vbNewLine
tmphtml = tmphtml & "newwin.document.write ('<html><title>View Image - 51windows.Net</title><head><meta http-equiv=Content-Type content=""text/html; charset=gb2312""></head><body style=""border:0px;margin:0px;"" onkeydown=if(event.keyCode==27){window.close()}><center><img title=""点击关闭窗口"" onclick=""window.close()"" style=""cursor:hand;"" border=""0"" src="/UploadFiles/2021-04-08/"> tmphtml = tmphtml & "}" & vbNewLine
tmphtml = tmphtml & "//-->" & vbNewLine
tmphtml = tmphtml & "</SCRIPT>" & vbNewLine
tmphtml = tmphtml & "<div class=""TitleDiv"">"& pagetitle &"</div>" & vbNewLine
tmphtml = tmphtml & pagestr & vbNewLine
tmphtml = tmphtml & "<div class=""FullDiv"">" & vbNewLine
tmphtml = tmphtml & outstr & vbNewLine
tmphtml = tmphtml & "</div>" & vbNewLine
tmphtml = tmphtml & "<div class=""TitleDiv"" align=""center""><a target=""_blank"" href=""http://www.51windows.Net"">www.51windows.Net</a></div>" & vbNewLine
tmphtml = tmphtml & info & vbNewLine
tmphtml = tmphtml & "</body>" & vbNewLine
tmphtml = tmphtml & "</html>" & 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)<nBits*4)
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
使用方法：将此文件放在sendto目录中（在运行中输入直接sendto，就可以打开），然后在有图片的文件夹上点右键，选择发送到，等一下，就OK了。下载操作演示
效果1：Logo展示
效果2：圣诞新年LOGO集锦
用到的技术：Scripting.FileSystemObject，Adodb.Stream。其中得到图片长宽用了秋水无恨的Adodb.Stream取得图像的高宽
复制代码 代码如下:
'///////////////////////////////////////////////
'VBS相册生成脚本，使用方法：将此文件放在sendto目录中（在运行中输入直接sendto，就可以打开），然后在有图片的文件夹上点右键，选择发送到，等一下，就OK了。
'海娃 http://www.51windows.Net
'更新日期:2004-12-30
'///////////////////////////////////////////////
Set ArgObj = WScript.Arguments
Set fsoBrowse = CreateObject("Scripting.FileSystemObject")
dim cpath,imgw,imgh,pagesize,wn,hn,pagetitle,filenamestart,firstpage
cpath=ArgObj(0)'传递路径
imgw = 240
imgh = 180
wn = 3
hn = 3
pagetitle = "图片展示 - 51windows.Net"
filenamestart = "Page_"
firstpage = "index.htm"
pagetitle2 = inputbox("请输入页面标题","请输入页面标题",pagetitle)
if isempty(pagetitle2) = false and len(pagetitle2) > 1 then
pagetitle = pagetitle2
end if
filenamestart2 = inputbox("请输入文件名前缀","请输入文件名前缀",filenamestart)
if isempty(filenamestart2) = false and len(filenamestart2) > 1 then
filenamestart = filenamestart2
end if
firstpage2 = inputbox("请输入第一页的文件名，点取消按序号生成","请输入第一页的文件名",firstpage)
if isempty(firstpage2) = false and len(filenamestart2) > 1 then
firstpage = firstpage2
else
firstpage = ""
end if
if len(firstpage) > 0 and (right(lcase(firstpage),4)<>".htm" and right(lcase(firstpage),5)<>".html") then
firstpage = firstpage & ".htm"
end if
imgw2 = inputbox("请输入小图的宽度","请输入小图的宽度",imgw)
if isnumeric(imgw2) and isempty(imgw2) = false then
imgw = imgw2
end if
imgh2 = inputbox("请输入小图的高度","请输入小图的高度",imgh)
if isnumeric(imgh2) and isempty(imgh2) = false then
imgh = imgh2
end if
wn2 = inputbox("请输入每行的图像数","请输入每行的图像数",wn)
if isnumeric(wn2) and isempty(wn2) = false then
wn = wn2
end if
hn2 = inputbox("请输入行数","请输入行数",hn)
if isnumeric(hn2) and isempty(hn2) = false then
hn = hn2
end if
dim info
info = "<!-- 本页面有 VBScript 相册生成脚本生成，http://www.51windows.Net -->"
pagesize = wn*hn
dim message
message = ""
message = message & "文件路径：" & chr(9) & cpath & vbnewline
message = message & "页面标题：" & chr(9) & pagetitle & vbnewline
message = message & "文件名前缀：" & chr(9) & filenamestart & vbnewline
message = message & "首页文件名：" & chr(9) & firstpage & vbnewline
message = message & "小图的宽度：" & chr(9) & imgw & vbnewline
message = message & "小图的高度" & chr(9) & imgh & vbnewline
message = message & "每行的图像数：" & chr(9) & wn & vbnewline
message = message & "行数：" & chr(9) & chr(9) & hn & vbnewline
message = message & vbnewline & "确定生成吗？" & vbnewline
dim StartRun
StartRun = msgbox(message,1,"VBS相册生成脚本")
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
thisstr = filenamearr(a)
thisstrarr = split(thisstr,"|")
if ubound(thisstrarr) = 3 then
dim w,h
w = thisstrarr(2)
h = thisstrarr(3)
okw = imgw
okh = imgh
if (w/h)>(imgw/imgh) then
if int(w)>=int(imgw) then
okw = imgw
okh = formatnumber(h*imgw/w,0)
else
okw = w
okh = h
end if
else
if int(h)>=int(imgh) then
okh = imgh
okw = formatnumber(w*imgh/h,0)
else
okw = w
okh = h
end if
end if
dim vspace
vspace = 0
if int(imgh)>int(okh) then
vspace = formatnumber((imgh-okh)/2,0)-3
end if
if int(vspace)<1 then
vspace = 0
end if
outstr = outstr & "<div class=""oneDiv"">" & vbnewline
outstr = outstr & " <div class=""ImgDiv""><a href="""& thisstrarr(0) &""" onclick=""ShowImg(this.href,"& w &","& h &");return false""><img border=""0"" title="""& thisstrarr(0) &"("& thisstrarr(1) &" byte)"" alt="""& thisstrarr(0) &""" src="/UploadFiles/2021-04-08/"> outstr = outstr & " <div class=""TextDiv""><a href="""& thisstrarr(0) &""" onclick=""ShowImg(this.href,"& w &","& h &");return false"">"& thisstrarr(0) &"</a></div>" & vbnewline
outstr = outstr & "</div>" & vbnewline
end if
if ((a+1) mod pagesize = 0) or (a = filenamenum) then
dim n1,nn
n1 = formatnumber(((a+1)/pagesize+0.49999),0)
nn = formatnumber((filenamenum+1)/pagesize+0.49999,0)
pagestr = "<div>"
if int(pagesize) = 1 then
nn = int(nn)+1
end if
for b = 1 to nn
bb = addzero(b,nn)
if int(b)<>int(n1) then
if int(b) = 1 and firstpage<>"" then
pagestr = pagestr & " <a href="""& firstpage &""">"& bb &"</a> "
else
pagestr = pagestr & " <a href="""& filenamestart &""& bb &".htm"">"& bb &"</a> "
end if
else
pagestr = pagestr & " "& bb &" "
end if
next
pagestr = pagestr & "</div><div align=""center"">"
if int(n1) = 1 then
pagestr = pagestr & "<span id=""PrevLink"">[ Prev ]</span>"
else
if int(n1) = 2 and firstpage<>"" then
pagestr = pagestr & "[ <a id=""PrevLink"" href="""& firstpage &""">Prev</a> ]"
else
pagestr = pagestr & "[ <a id=""PrevLink"" href="""& filenamestart &""& addzero((n1-1),nn) &".htm"">Prev</a> ]"
end if
end if
if int(n1) = int(nn) then
pagestr = pagestr & "<span id=""NextLink"">[ Next ]</span>"
else
pagestr = pagestr & "[ <a id=""NextLink"" href="""& filenamestart &""& addzero((n1+1),nn) &".htm"">Next</a> ]"
end if
if int(nn) > 1 then
pagestr = "<div class=""pageDiv"">"& pagestr & "</div></div>"
else
pagestr = ""
end if
if int(n1) = 1 and firstpage<>"" then
creatfile outstr,pagestr,"/"& firstpage
else
creatfile outstr,pagestr,"/"& filenamestart &""& addzero(n1,nn) &".htm"
end if
outstr = ""
end if
next
if err=0 then
msgbox "文件已生成"
else
msgbox "CreatPageHtml 出错了:" & err.description
err.clear
end if
end sub
function addzero(num1,numn)
addzero = right("00000000"&num1,len(numn))
end function
function formattitle(str)
str1 = str
str1 = replace(str1,"""",""")
formattitle = str1
end function
sub creatfile(outstr,pagestr,name)
ON ERROR RESUME NEXT
dim tmphtml
tmphtml = tmphtml & "<html>" & vbNewLine
tmphtml = tmphtml & "<head>" & vbNewLine
tmphtml = tmphtml & "<meta http-equiv=""Content-Type"" content=""text/html; charset=gb2312"">" & vbNewLine
tmphtml = tmphtml & "<meta name=""GENERATOR"" content=""Microsoft FrontPage 4.0"">" & vbNewLine
tmphtml = tmphtml & "<meta name=""ProgId"" content=""FrontPage.Editor.Document"">" & vbNewLine
tmphtml = tmphtml & "<title>"& pagetitle &"</title>" & vbNewLine
tmphtml = tmphtml & "<style>" & vbNewLine
tmphtml = tmphtml & "<!--" & vbNewLine
tmphtml = tmphtml & "body {margin:0px;}" & vbNewLine
tmphtml = tmphtml & ".TitleDiv {margin:2px;padding:2px;display:block;font-size:18pt;font-family:Verdana;width:"& (int(imgw)+20)*wn &"px;}" & vbNewLine
tmphtml = tmphtml & ".pageDiv {margin:2px;padding:2px;display:block;font-size:11pt;font-family:Verdana;word-break : break-all;width:"& (int(imgw)+20)*wn &"px;}" & vbNewLine
tmphtml = tmphtml & "a {word-break : break-all;}" & vbNewLine
tmphtml = tmphtml & ".FullDiv {margin:0px;padding:0px;width:"& (int(imgw)+20)*wn &"px;}" & vbNewLine
tmphtml = tmphtml & ".oneDiv {background-color: #FFFFFF; border: 0px solid #F2F2F2; padding: px;margin:2px;width:"& (int(imgw)+12) &"px;height:"& (int(imgh)+30) &"px;float:left;}" & vbNewLine
tmphtml = tmphtml & ".ImgDiv {background-color: #F2F2F2; border: 1px solid #999999; padding: 2px;margin:2px;width:"& (int(imgw)+8) &"px;height:"& (int(imgh)+4) &"px;overflow:hidden;text-align:center;}" & vbNewLine
tmphtml = tmphtml & ".TextDiv {background-color: #F2F2F2; border: 1px solid #999999; padding: 2px;margin:2px;width:"& (int(imgw)+8) &"px;height:20px;overflow:hidden;text-align:center;font-size:9pt;font-family:Verdana;}" & vbNewLine
tmphtml = tmphtml & "-->" & vbNewLine
tmphtml = tmphtml & "</style>" & vbNewLine
tmphtml = tmphtml & "</head>" & vbNewLine
tmphtml = tmphtml & "<body onkeydown=""if(event.keyCode==37){if(PrevLink.href){window.open(PrevLink.href,'_self','')}}else if(event.keyCode==39){if(NextLink.href){window.open(NextLink.href,'_self','')}}"">" & vbNewLine
tmphtml = tmphtml & "<SCRIPT LANGUAGE=""JavaScript"">" & vbNewLine
tmphtml = tmphtml & "<!--" & vbNewLine
tmphtml = tmphtml & "function ShowImg(url,w,h)" & vbNewLine
tmphtml = tmphtml & "{" & vbNewLine
tmphtml = tmphtml & "newwin = window.open(""about:blank"","""",""width=""+(w-3)+"",height=""+(h-3)+"",left=""+(window.screen.width-w)/2+"",top=""+(window.screen.height-h)/2+"""")" & vbNewLine
tmphtml = tmphtml & "newwin.document.write ('<html><title>View Image - 51windows.Net</title><head><meta http-equiv=Content-Type content=""text/html; charset=gb2312""></head><body style=""border:0px;margin:0px;"" onkeydown=if(event.keyCode==27){window.close()}><center><img title=""点击关闭窗口"" onclick=""window.close()"" style=""cursor:hand;"" border=""0"" src="/UploadFiles/2021-04-08/"> tmphtml = tmphtml & "}" & vbNewLine
tmphtml = tmphtml & "//-->" & vbNewLine
tmphtml = tmphtml & "</SCRIPT>" & vbNewLine
tmphtml = tmphtml & "<div class=""TitleDiv"">"& pagetitle &"</div>" & vbNewLine
tmphtml = tmphtml & pagestr & vbNewLine
tmphtml = tmphtml & "<div class=""FullDiv"">" & vbNewLine
tmphtml = tmphtml & outstr & vbNewLine
tmphtml = tmphtml & "</div>" & vbNewLine
tmphtml = tmphtml & "<div class=""TitleDiv"" align=""center""><a target=""_blank"" href=""http://www.51windows.Net"">www.51windows.Net</a></div>" & vbNewLine
tmphtml = tmphtml & info & vbNewLine
tmphtml = tmphtml & "</body>" & vbNewLine
tmphtml = tmphtml & "</html>" & 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)<nBits*4)
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
使用方法：将此文件放在sendto目录中（在运行中输入直接sendto，就可以打开），然后在有图片的文件夹上点右键，选择发送到，等一下，就OK了。下载操作演示
效果1：Logo展示
效果2：圣诞新年LOGO集锦
下一篇：飘叶千夫指源代码，又称qq刷屏器