function createnewsclass(id)
dim arrcont:arrcont = getcurclasscount(id)
dim i,j
for i = 0 to arrcont - 1
dim Temp:Temp = ""
Temp = processcustomtag(loadtempletfile("../templet/" & getclassall(id,1) & ""))
Temp = X_processcustomtag(Temp)
dim charclass
set charclass = new stringclass
dim PatrnStr
PatrnStr = "<title>.*?</title>"
Temp = (PatrnStr,Temp,"<title>" & (getclassname(id)) & " - " & site_name & "</title>")
PatrnStr = "\{\$guide\$\}"
Temp = (PatrnStr,Temp,guide(id))
PatrnStr = "\{\$keywords\$\}"
Temp = (PatrnStr,Temp,site_keywords)
PatrnStr = "\{\$search\$\}"
Temp = (PatrnStr,Temp,search())
PatrnStr = "\{\$description\$\}"
Temp = (PatrnStr,Temp,site_description)
PatrnStr = "\{\$copyright\$\}"
Temp = (PatrnStr,Temp,site_copyright)
PatrnStr = "\{\$root\$\}"
Temp = (PatrnStr,Temp,site_root)
dim sPATH,cPATH:cPATH = "" & site_root & "/" & site_html & "/" & getclasspath(id) & "/"
createdir((cPATH))
dim PageHTM:PageHTM = ""
if i = 0 then
sPATH = "" & cPATH & "index" & site_extname & ""
else
sPATH = "" & cPATH & "index" & site_extname & ""
sPATH = left(sPATH,(len(sPATH)-len(site_extname))) & "_" & i + 1 & site_extname
end if
if arrcont >= 2 then
if i = 0 then
PageHTM= PageHTM& "【Home Page】-"
PageHTM=PageHTM& "【Previous Page】"
end if
if i > 1 then
PageHTM= PageHTM& "【<a href=""index" & site_extname & "">Home Page</a>]-"
PageHTM= PageHTM& "【<a href=""index" & "_" & i & site_extname & "">Previous Page</a>]"
end if
if i = 1 Then
PageHTM= PageHTM& "【<a href=""index" & site_extname & "">Home Page</a>]-"
PageHTM= PageHTM& "【<a href=""index" & site_extname & "">Previous Page</a>]"
end if
PageHTM = PageHTM & "-[page 1 & i + 1 & "</font> Page]/[Total pages of color=""red"">" & arrcont & "</font>-"
if i < arrcont - 1 then
PageHTM= PageHTM& "【<a href=""index" & "_" & i + 2 & site_extname & "">Next Page</a>]-"
PageHTM= PageHTM& "【<a href=""index" & "_" & arrcont & site_extname & "">Last Page</a>]-"
end if
if i = arrcont - 1 then
PageHTM= PageHTM& "【Next Page】-"
PageHTM= PageHTM& "【Last Page】-"
end if
PageHTM = PageHTM & "<select name=""page"" onchange=""=[].value"">"
PageHTM= PageHTM& "<option selected>Page/code</option>"
PageHTM = PageHTM & "<option value=""index" & site_extname & "">Page 1</option>"
for j = 1 to arrcont - 1
PageHTM = PageHTM & "<option value=""index" & "_" & j + 1 & site_extname & "">" & j + 1 & "Page</option>"
next
PageHTM = PageHTM & "</select>"
end if
PatrnStr = "{news:[^<>]+?\/}"
Temp = (PatrnStr,Temp,id,i + 1,"<p align=""center"">" & PageHTM & "</p>" & chr(10) & "")
dim objstream
set objstream = ("")
with objstream
.open
.charset = "" & chrset & ""
.position =
.writetext = Temp
.savetofile (sPATH),2
.close
end with
next
set objstream = nothing
if <> 0 then
createnewsclass = false
else
createnewsclass = true
end if
end function
function createnewsfile(id)
dim rs,sql
set rs = ("")
sql = "select id,classid,title,content,author,source,keywords,bimg,simg,filename,pagetype,addtime from NCMS_news where "
if databox(10,0) = 0 then
Temp = processcustomtag(loadtempletfile("../templet/" & getclassall(databox(1,0),2) & ""))
Temp = X_processcustomtag(Temp)
else
Temp = processcustomtag(loadtempletfile("../templet/" & site_stemp & ""))
Temp = X_processcustomtag(Temp)
end if
dim charclass
set charclass = new stringclass
dim PatrnStr,AdvCont
PatrnStr = "<title>.*?</title>"
Temp = (PatrnStr,Temp,"<title>" & (databox(2,0)) & " - " & site_name & "</title>")
PatrnStr = "{news:[^<>]+?\/}"
Temp = (PatrnStr,Temp,databox(1,0),databox(0,0),databox(6,0))
PatrnStr = "\{\$id\$\}"
Temp = (PatrnStr,Temp,databox(0,0))
PatrnStr = "\{\$classid\$\}"
Temp = (PatrnStr,Temp,databox(1,0))
PatrnStr = "\{\$title\$\}"
Temp = (PatrnStr,Temp,databox(2,0))
PatrnStr = "\{\$author\$\}"
Temp = (PatrnStr,Temp,databox(4,0))
PatrnStr = "\{\$source\$\}"
Temp = (PatrnStr,Temp,databox(5,0))
PatrnStr = "\{\$keywords\$\}"
Temp = (PatrnStr,Temp,databox(6,0))
PatrnStr = "\{\$click\$\}"
Temp = (PatrnStr,Temp,click(databox(0,0)))
PatrnStr = "\{\$addtime\$\}"
Temp = (PatrnStr,Temp,databox(11,0))
PatrnStr = "\{\$guide\$\}"
Temp = (PatrnStr,Temp,guide(databox(1,0)))
PatrnStr = "\{\$search\$\}"
Temp = (PatrnStr,Temp,search())
PatrnStr = "\{\$fontselect\$\}"
Temp = (PatrnStr,Temp,fontselect())
PatrnStr = "\{\$toolbar\$\}"
Temp = (PatrnStr,Temp,toolbar(databox(0,0)))
PatrnStr = "\{\$copyurl\$\}"
Temp = (PatrnStr,Temp,copyurl())
PatrnStr = "\{\$description\$\}"
Temp = (PatrnStr,Temp,site_description)
PatrnStr = "\{\$copyright\$\}"
Temp = (PatrnStr,Temp,site_copyright)
PatrnStr = "\{\$root\$\}"
Temp = (PatrnStr,Temp,site_root)
PatrnStr = "\{\$advarea\$\}"
AdvCont = databox(3,0)
AdvCont = (PatrnStr,AdvCont,advshow(site_advcode))
dim tempArr,n,sPATH,ePATH,cPATH:cPATH = "" & site_root & "/" & site_html & "/" & getclasspath(databox(1,0)) & "/"
if instr(databox(9,0),"/") = 0 then
createdir((cPATH))
else
tempArr = split(databox(9,0),"/")
for n = 0 to ubound(tempArr)
ePATH = replace(databox(9,0),tempArr(n),"")
next
createdir((cPATH & ePATH))
end if
dim TTemp:TTemp = Temp
dim arrcont:arrcont = split(AdvCont,"{$split$}",-1,1)
dim PageHTM:PageHTM = ""
dim i,j,k:k = ubound(arrcont)
for i = 0 to k
if i = 0 then
sPATH = "" & cPATH & databox(9,0) & site_extname & ""
else
sPATH = "" & cPATH & databox(9,0) & site_extname & ""
sPATH = left(sPATH,(len(sPATH)-len(site_extname))) & "_" & i + 1 & site_extname
end if
if sPATH = "" then
createnewsfile = false
exit function
end if
if k >= 1 then
PageHTM = "<p align=""center"">[This news is a total of <font color=""red"">" & k + 1 & "</font> pages]-"
if i = 0 then
PageHTM= PageHTM& "【Home Page】-"
PageHTM= PageHTM& "【Previous Page】-"
end if
if i > 1 then
PageHTM= PageHTM& "【<a href=""" & cPATH & databox(9,0) & site_extname & "">Home</a>]-"
PageHTM= PageHTM& "【<a href=""" & cPATH & databox(9,0) & "_" & i & site_extname & "">Previous Page</a>]-"
end if
if i = 1 Then
PageHTM= PageHTM& "【<a href=""" & cPATH & databox(9,0) & site_extname & "">Home</a>]-"
PageHTM= PageHTM& "【<a href=""" & cPATH & databox(9,0) & site_extname & "">Previous Page</a>]-"
end if
if i < k then
PageHTM= PageHTM& "【<a href=""" & cPATH & databox(9,0) & "_" & i + 2 & site_extname & "">Next Page</a>]-"
PageHTM= PageHTM& "【<a href=""" & cPATH & databox(9,0) & "_" & k + 1 & site_extname & "">Last Page</a>]-"
end if
if i = k then
PageHTM= PageHTM& "【Next Page】-"
PageHTM= PageHTM& "【Last Page】-"
end if
PageHTM = PageHTM & "[Currently on page <font color=""red"">" & i + 1 & "</font> page]</p>"
else
PageHTM = ""
end if
PatrnStr = "\{\$content\$\}"
Temp = (PatrnStr,TTemp,"" & chr(10) & "<div id=""content"">" & chr(10) & arrcont(i) & PageHTM & chr(10) & "</div>" & chr(10))
dim objstream
set objstream = ("")
with objstream
.open
.charset = "" & chrset & ""
.position =
.writetext = X_processcustomtag(Temp)
.savetofile (sPATH),2
.close
end with
set objstream = nothing
next
if <> 0 then
createnewsfile = false
else
("update NCMS_news set created=1 where "
end if
end function
function createnewsjs(show,id,len,num,lih,col,filename)
dim TempHTM,xsql,rs,databox,i
TempHTM = "('<table cellpadding=\""0\"" cellspacing=\""0\"" width=\""100%\"" border=\""0\"">');"
TempHTM = TempHTM & "('<tr>');"
select case show
case "new"
if id = 0 then
set rs = ("select top " & num & " classid,title,filename from NCMS_news where created=1 and pagetype=0 order by id desc")
else
set rs = ("select top " & num & " classid,title,filename from NCMS_news where classid in(" & id & allchildclass(id) & ") and created=1 and pagetype=0 order by id desc")
end if
case "elite"
if id = 0 then
set rs = ("select top " & num & " classid,title,filename from NCMS_news where elite=1 and created=1 and pagetype=0 order by id desc")
else
set rs = ("select top " & num & " classid,title,filename from NCMS_news where classid in(" & id & allchildclass(id) & ") and elite=1 and created=1 and pagetype=0 order by id desc")
end if
case "hot"
if id = 0 then
set rs = ("select top " & num & " classid,title,filename from NCMS_news where click>=100 and created=1 and pagetype=0 order by click desc")
else
set rs = ("select top " & num & " classid,title,filename from NCMS_news where classid in(" & id & allchildclass(id) & ") and click>=100 and created=1 and pagetype=0 order by click desc")
end if
case else
("[News Type] Parameter Error!")
()
end select
if then
:set rs = nothing
TempHTM = "('<li><font color=\""red\"">No news yet!<\/font><\/li>');"
else
databox = ()
:set rs = nothing
for i = 0 to ubound(databox,2)
TempHTM = TempHTM & "('<td height=\""" & lih & "\"" align=\""left\"" valign=\""middle\"">·<a href=\""" & site_root & "/" & site_html & "/" & getclasspath(databox(0,i)) & "/" & databox(2,i) & site_extname & "\"" title=\""" & databox(1,i) & "\"" target=\""_blank\"">" & gottopic(databox(1,i),len) & "<\/a><\/td>');"
if i = ubound(databox,2) then
TempHTM = TempHTM & "('<\/tr>');"
else
if cint((i+1) mod col) = 0 then
TempHTM = TempHTM & "('<\/tr>');"
TempHTM = TempHTM & "('<tr>');"
end if
end if
next
databox = ""
TempHTM = TempHTM & "('<\/table>');"
end if
if checkfolder("" & site_root & "/jss/") = false then
createdir(("" & site_root & "/jss/"))
end if
if checkfile("" & site_root & "/jss/" & filename & ".js") = true then
call alertbox("The file already exists! Please change the file name!",2)
end if
dim objstream
set objstream = ("")
with objstream
.open
.charset = "" & chrset & ""
.position =
.writetext = TempHTM
.savetofile ("" & site_root & "/jss/" & filename & ".js"),2
.close
end with
set objstream = nothing
if <> 0 then
createnewsjs = false
else
createnewsjs = true
end if
end function
function getnewstitle(id)
dim rs,tempstr
set rs = ("select title from NCMS_news where title"))
end if
:set rs = nothing
getnewstitle = tempstr
end function
function getclasspath(id)
dim rs,tempstr
set rs = ("select ename from NCMS_class where ename")
end if
:set rs = nothing
getclasspath = tempstr
end function
function getclassid(id)
dim rs,tempstr
set rs = ("select classid from NCMS_news where classid")
end if
:set rs = nothing
getclassid = tempstr
end function
function getclassname(id)
dim rs,tempstr
set rs = ("select cname from NCMS_class where id= " & id)
if not then
tempstr = rs("cname")
end if
:set rs = nothing
getclassname = tempstr
end function
function allchildclass(id)
dim rs
set rs = ("select id from NCMS_class where parent=" & id)
while not
allchildclass = allchildclass & "," & rs("id")
allchildclass = allchildclass & allchildclass(rs("id"))
wend
:set rs = nothing
end function
function getclassall(id,stype)
dim rs,tempstr
select case stype
case "1"
set rs = ("select ctemp from NCMS_class where ctemp")
end if
:set rs = nothing
getclassall = tempstr
case "2"
set rs = ("select ntemp from NCMS_class where ntemp")
end if
:set rs = nothing
getclassall = tempstr
case "3"
set rs = ("select fname from NCMS_class where fname")
end if
:set rs = nothing
getclassall = tempstr
case else
("Failed to obtain column attributes!")
()
end select
end function
function advshow(advcode)
if advcode = "" then
advshow = ""
exit function
else
dim advarr
advarr = split(advcode,"|||")
if ubound(advarr) = 0 then
advshow = "" & chr(10) & "<table style=""padding:0px;width:250px;height:250px"" cellspacing=""0"" cellpadding=""0"" align=""left"" border=""0"">" & chr(10)
advshow = advshow & "<tr>" & chr(10)
advshow = advshow & "<td>" & advcode & "</td>" & chr(10)
advshow = advshow & "</tr>" & chr(10)
advshow = advshow & "</table>" & chr(10)
else
dim n:randomize
n = int((ubound(advarr) + 1) * rnd)
advshow = "" & chr(10) & "<table style=""padding:0px;width:250px;height:250px"" cellspacing=""0"" cellpadding=""0"" align=""left"" border=""0"">" & chr(10)
advshow = advshow & "<tr>" & chr(10)
advshow = advshow & "<td>" & advarr(n) & "</td>" & chr(10)
advshow = advshow & "</tr>" & chr(10)
advshow = advshow & "</table>" & chr(10)
end if
end if
end function
function click(id)
click = "<script language=""javascript"" type=""text/javascript"" src=""" & site_root & "/tools/?""></script>"
end function
function fontselect()
fontselect = "" & chr(10) & "<div id=""fontselect"">" & chr(10)
fontselect = fontselect & "<ul>" & chr(10)
fontselect = fontselect & "<li id=""explain"">Font size</li>" & chr(10)
fontselect = fontselect & "<li><a href=""javascript:doZoom(12)"">small</a></li>" & chr(10)
fontselect = fontselect & "<li><a href=""javascript:doZoom(14)"">middle</a></li>" & chr(10)
fontselect = fontselect & "<li><a href=""javascript:doZoom(16)"">big</a></li>" & chr(10)
fontselect = fontselect & "</ul>" & chr(10)
fontselect = fontselect & "</div>" & chr(10)
end function
function toolbar(id)
toolbar = "" & chr(10) & "<div id=""toolbar"">" & chr(10)
toolbar = toolbar & "<ul>" & chr(10)
tools = toolsetbar & "<li id=""explain"">Browsing Tools</li>" & chr(10)
toolset=""" & "<li><a href=""" & site_root & "/tools/?news&newstitle=" & getnewstitle(id) & "#comment"" target=""_blank"" title=""News Comment"">News Comment</a><li>" & chr(10)
toolsetbar = toolsetbar & "<li><a href=""javascript:()"" title=""Print this article"">Print this article</a><li>" & chr(10)
toolsetbar = toolsetbar & "<li><a href=""javascript:()"" title=""Close this page"">Close this page</a><li>" & chr(10)
toolsetbar = toolsetbar & "<li><a href=""javascript:scroll(0,0)"" title=""Back to top"">Back to top</a><li>" & chr(10)
toolbar = toolbar & "</ul>" & chr(10)
toolbar = toolbar & "</div>" & chr(10)
end function
function copyurl()
copyurl = "" & chr(10) & "<div id=""copyurl"">" & chr(10)
copyurl = copyurl & "<script language=""javascript"" type=""text/javascript"">('<input name=""url"" type=""text"" value=""' + '"" readonly=""true"" /><input name=""btn"" type=""button"" value=""Copy the address of this page to share with friends"" onclick=""copyurl();"" //');</script>" & chr(10)
copyurl = copyurl & "</div>" & chr(10)
end function
function search()
search = "" & chr(10) & "<div id=""search"">" & chr(10)
search = search & "<form name=""form"" action=""" & site_root & "/tools/"" method=""get"">" & chr(10)
search = search & "<input name=""kw"" type=""text"" value="""" />" & chr(10)
search = search & "<select name=""tn"">" & chr(10)
search = search & "<option value=""1"">Title</option>" & chr(10)
search = search & "<option value=""2"">Author</option>" & chr(10)
search = search & "<option value=""3"">content</option>" & chr(10)
search = search & "</select>" & chr(10)
search = search & "<input name=""do"" type=""hidden"" value=""ok"" />" & chr(10)
search = search & "<input name=""search"" type=""submit"" value=""Search"" />" & chr(10)
search = search & "</form>" & chr(10)
search = search & "</div>" & chr(10)
end function
function rannumkey(digits)
dim chararray(10)
chararray(0) = "0"
chararray(1) = "1"
chararray(2) = "2"
chararray(3) = "3"
chararray(4) = "4"
chararray(5) = "5"
chararray(6) = "6"
chararray(7) = "7"
chararray(8) = "8"
chararray(9) = "9"
randomize
do while len(output) < digits
dim num:num = cstr(chararray(int((10-0+1) * rnd + 0)))
dim output:output = output + num
loop
rannumkey = output
end function
function makefntype(datestr,types,classid)
select case types
case "1"
makefntype = year(datestr) & "/" & month(datestr) & "-" & day(datestr) & "/" & getclassall(classid,3) & rannumkey(8) 'Year/month-day/random number
case "2"
makefntype = year(datestr) & "/" & month(datestr) & "/" & day(datestr) & "/" & getclassall(classid,3) & rannumkey(8) 'Year/month/day/random number
case "3"
makefntype = year(datestr) & "-" & month(datestr) & "-" & day(datestr) & "/" & getclassall(classid,3) & rannumkey(8) 'Year-month-day/random number
case "4"
makefntype = year(datestr) & "-" & month(datestr) & "/" & day(datestr) & "/" & getclassall(classid,3) & rannumkey(8) 'Year-month/day/random number
case "5"
makefntype = year(datestr) & "/" & month(datestr) & "/" & getclassall(classid,3) & rannumkey(8) 'Year/month/random number
case "6"
makefntype = year(datestr) & "-" & month(datestr) & "/" & getclassall(classid,3) & rannumkey(8) 'Year-month/random number
case "7"
makefntype = year(datestr) & month(datestr) & day(datestr) & "/" & getclassall(classid,3) & rannumkey(8) 'Year, monthday/rannumkey
case "8"
makefntype = year(datestr) & "/" & getclassall(classid,3) & rannumkey(8) 'Year/Rannumkey
case "9"
makefntype = year(datestr) & month(datestr) & day(datestr) & rannumkey(3) 'Year, month, day, day, random number
case "10"
makefntype = getclassall(classid,3) & rannumkey(16) '16-bit random number
case "11"
makefntype = getclassall(classid,3) & md5(datestr & rannumkey(3),16) '16-bit md5 encrypted characters
case "12"
makefntype = getclassall(classid,3) & year(datestr) & month(datestr) & day(datestr) & hour(datestr) & minute(datestr) & second(datestr) & rannumkey(3) 'Year, month, day, hour, minute, and seconds
case else
makefntype = getclassall(classid,3) & year(datestr) & month(datestr) & day(datestr) & hour(datestr) & minute(datestr) & second(datestr) & rannumkey(3) 'Year, month, day, hour, minute, and seconds
end select
end function
function dateformat(datestr,types)
dim datestring
if isdate(datestr) = false then
datestring = ""
end if
select case types
case "1"
datestring = year(datestr) & "-" & month(datestr) & "-" & day(datestr)
case "2"
datestring = year(datestr) & "." & month(datestr) & "." & day(datestr)
case "3"
datestring = month(datestr) & "-" & day(datestr) & "-" & year(datestr)
case "4"
datestring = month(datestr) & "." & day(datestr) & "." & year(datestr)
case "5"
datestring = year(datestr) & month(datestr) & day(datestr)
case "6"
datestring = hour(datestr) & minute(datestr) & second(datestr)
case "7"
datestring = year(datestr) & "Year" & month(datestr) & "month" & day(datestr) & "day"
case else
datestring = datestr
end select
dateformat = datestring
end function
function formattagdate(mdate,temp)
if not isdate(mdate) or temp = "" then
formattagdate = temp
exit function
end if
dim myear:myear = year(mdate)
dim mmonth:mmonth = month(mdate)
dim mday:mday = day(mdate)
dim mhour:mhour = hour(mdate)
dim mmin:mmin = minute(mdate)
dim msec:msec = second(mdate)
temp = replace(temp,"{Y}",year(mdate))
temp = replace(temp,"{y}",right(year(mdate),2))
temp = replace(temp,"{M}",month(mdate))
temp = replace(temp,"{m}",right("00" & month(mdate),2))
temp = replace(temp,"{D}",day(mdate))
temp = replace(temp,"{d}",right("00" & day(mdate),2))
formattagdate = temp
end function
function strlength(str)
on error resume next
dim winnt_chinese
winnt_chinese = (len("China") = 2)
if winnt_chinese then
dim l, t, c
dim i
l = len(str)
t = l
for i = 1 to l
c = asc(mid(str,i,1))
if c < 0 then c = c + 65536
if c > 255 then
t = t + 1
end if
next
strlength = t
else
strlength = len(str)
end if
if <> 0 then
end function
function gottopic(byval str,byval strlen)
if str = "" or str = null then
gottopic = ""
exit function
end if
dim l,t,c,i,tstr
str = replace(replace(replace(replace(str," "," "),""",chr(34)),">",">"),"<","<")
l = len(str)
t = 0
tstr = str
strlen = clng(strlen)
for i = 1 to l
c = abs(asc(mid(str,i,1)))
if c > 255 then
t = t + 2
else
t = t + 1
end if
if t >= strlen then
tstr = left(str,i)
exit for
end if
next
if tstr <> str then
tstr = tstr & "..."
end if
gottopic = replace(replace(replace(replace(tstr," "," "),chr(34),"""),">",">"),"<","<")
end function
function insertchr(num)
dim str1:str1 = "├"
dim str2:str2 = ""
dim iii
for iii = 2 to num
str2 = str2 & "│ "
next
insertchr = str2&str1
end function
class classlist
private class_id
private class_table
private class_parentid
private class_name
public property let id(str)
class_id = str
end property
public property let table(str)
class_table = str
end property
public property let parentid(str)
class_parentid = str
end property
public property let name(str)
class_name = str
end property
dim list()
dim i,n
private sub class_initialize()
i = 0:n = 0
end sub
public function classarry(thisid,id)
dim rsclass,classsql
if id > 0 then
classsql = "select * from " & class_table & " where " & class_parentid & "=" & thisid
else
classsql = "select * from " & class_table & " where " & class_id & "=" & thisid
end if
set rsclass = (classsql)
n = n + 1
do while not
list(0,i) = rsclass(class_id)
list(1,i) = rsclass(class_name)
list(2,i) = n
i = i + 1
thisid = classarry(rsclass(class_id),1)
loop
n = n - 1
end function
public function arrylist()
dim rsclass
set rsclass = ("select count(" & class_id & ") from " & class_table)
dim lenght
lenght = rsclass(0)
redim list(2,lenght)
dim rspclass
set rspclass = ("select " & class_id & " from " & class_table & " where " & class_parentid & "=0")
do while not
call classarry(rspclass(class_id),0)
loop
arrylist = list
end function
end class
class imginfo
dim aso
private sub class_initialize
set aso = createobject("")
= 3
= 1
end sub
private sub class_terminate
set aso = nothing
end sub
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
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
dim i
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
Dim i
for i = 1 to lenb(bin)
ret = ret*256 + ascb(midb(bin,i,1))
next
binval2 = ret
end function
private function getimagesize(filespec)
dim ret(3)
(filespec)
dim bflag
bflag = (3)
select case hex(binval(bflag))
case "4E5089":
(15)
ret(0) = "PNG"
ret(1) = binval2((2))
(2)
ret(2) = binval2((2))
case "464947":
(3)
ret(0) = "GIF"
ret(1) = binval((2))
ret(2) = binval((2))
case "535746":
(5)
bindata = (1)
sconv = num2str(ascb(bindata),2,8)
nbits = str2num(left(sconv,5),2)
sconv = mid(sconv,6)
while(len(sconv)<nbits*4)
bindata = (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
dim p1
do:p1 = binval((1)):loop while p1 = 255 and not
if p1 > 191 and p1 < 196 then exit do else (binval2((2))-2)
do:p1 = binval((1)):loop while p1 < 255 and not
loop while true
(3)
ret(0) = "JPG"
ret(2) = binval2((2))
ret(1) = binval2((2))
case else:
if left(bin2str(bflag),2) = "BM" then
(15)
ret(0) = "BMP"
ret(1) = binval((4))
ret(2) = binval((4))
else
ret(0) = ""
end if
end select
ret(3)="width=""" & ret(1) &""" height=""" & ret(2) &""""
getimagesize = ret
end function
public function imgW(pic_path)
dim imgfso
set imgfso = ("")
if ((pic_path)) then
dim imgfs,ext
set imgfs = (pic_path)
ext = (pic_path)
select case ext
case "gif","bmp","jpg","png":
dim arr
arr = getimagesize()
imgW = arr(1)
end select
set imgfs = nothing
else
imgW = 0
end if
set imgfso = nothing
end function
public function imgH(pic_path)
dim imgfso
set imgfso = ("")
if ((pic_path)) then
dim imgfs,ext
set imgfs = (pic_path)
ext = (pic_path)
select case ext
case "gif","bmp","jpg","png":
dim arr
arr = getimagesize()
imgH = arr(2)
end select
set imgfs = nothing
else
imgH = 0
end if
set imgfso = nothing
end function
end class
Previous page1234Next pageRead the full text