忠网广告 系统 用到的几个函数

复制代码 代码如下:

<%  '///****************************************************************** '  常用公共函数库 文件名：PubFunction.asp  '******************************************************************///    Const Go_back="<a href='javascript:history.back(1)'>[返回上页]</a>"   Const Closer="<a href='javascript:self.close()'>『关闭窗口』</a>"    '//******************************************************************** '  PubFgdy(Test,Tag,Bh)  根据分隔符和标号调用指定字符串的指定值函数，参数：Test 被分隔的字符串，Tag 分隔符，Bh 标号 '********************************************************************//   Function PubFgdy(Test,Tag,Bh)     PubFgdy=""   if Test<>"" and isnumeric(Bh)=true Then   Dim Tests   Tests=split(Test&Tag,Tag)   if Bh<Ubound(Tests) then   PubFgdy=Tests(Bh)     end if   else   PubFgdy=""   exit function   end if   end function   '//******************************************************************** '  PubCodeGF(OldTest) 代码规范函数， 参数：OldTest 原始内容， NewTest 新内容   '********************************************************************//   Function PubCodeGF(OldTest)   dim NewTest:NewTest=trim(OldTest)   if isnull(NewTest) or NewTest="" then code_admin="":exit function   NewTest=replace(NewTest,"'","""")   PubCodeGF=NewTest   end function '//******************************************************************** '  PubCodehtml(OldTest) 屏蔽HTML代码函数， 参数：OldTest  原始内容， NewTest  新内容  '********************************************************************//   function PubCodehtml(OldTest)   dim NewTest:NewTest=OldTest   if isnull(NewTest) or NewTest="" then PubCodehtml="":exit function   NewTest=replace(NewTest,"<","<")   NewTest=replace(NewTest,">",">")   NewTest=replace(NewTest,chr(39),"'")        '单引号   NewTest=replace(NewTest,chr(34),""")        '双引号   NewTest=replace(NewTest,chr(32)," ")        '空格   NewTest=replace(NewTest,chr(9)," 　 ")'table   NewTest=replace(NewTest,chr(10),"<br>")        '回车   NewTest=replace(NewTest,chr(13),"<br>")   PubCodehtml=NewTest   end function '//******************************************************************** '  PubCtime() 组合系统时间为正常字符串 含 年、月、日、时、分、秒 如：200412172356 '********************************************************************//   Function PubCtime()   Dim GcChars   GcChars = now()   GcChars = replace(GcChars,"-","")   GcChars = replace(GcChars," ","")    GcChars = replace(GcChars,":","")   GcChars = replace(GcChars,"PM","")   GcChars = replace(GcChars,"AM","")   GcChars = replace(GcChars,"上午","")   GcChars = replace(GcChars,"下午","")   GcChars = int(GcChars) + int((10-1+1)*Rnd + 1)   PubCtime=GcChars           end function '//******************************************************************** ' PubFolderIfcz(Foldername) 判断目录是否存在，需要　fso支持 参数：Foldername  '********************************************************************// Function PubFolderIfcz(Foldername)  Dim fso FolderIfcz=false  if Foldername<>"" then  Foldername=Server.MapPath(Foldername)   Set fso = server.CreateObject("Scripting.FileSystemObject")   if fso.FolderExists(Foldername) then   FolderIfcz=true   end if   set fso = nothing    end if end Function '//******************************************************************** ' PubFileIfcz(Filename) 判断文件是否存在，需要　fso支持 参数：Filename  '********************************************************************// Function PubFileIfcz(Filename)  Dim fso PubFileIfcz=false  if Filename<>"" then  Filename=Server.MapPath(Filename)   Set fso = server.CreateObject("Scripting.FileSystemObject")   if fso.FileExist(Filename) then   PubFileIfcz=true   end if   set fso = nothing    end if end Function '//******************************************************************** ' PubDeleteFile(Filename) 删除文件，需要　fso支持 参数：Filename 预删除文件的相对路径 '********************************************************************// Function PubDeleteFile(Filename) '删除文件 Dim fso  if Filename<>"" then  Filename=Server.MapPath(Filename)   Set fso = server.CreateObject("Scripting.FileSystemObject")   if fso.FileExists(Filename) then   fso.DeleteFile Filename   PubDeleteFile="Suc"   end if   set fso = nothing    end if end Function '//******************************************************************** ' PubDeleteFolder(Foldername) 删除目录，需要　fso支持 参数：Foldername 预删除目录的相对路径 '********************************************************************// Function PubDeleteFolder(Foldername) '删除目录 Dim fso  if Foldername<>"" then  Foldername=Server.MapPath(Foldername)   Set fso = server.CreateObject("Scripting.FileSystemObject")   if fso.FolderExists(Foldername) then   fso.DeleteFolder Foldername   PubDeleteFolder="Suc"   end if   set fso = nothing    end if end Function '//******************************************************************** ' PubCopyFile(Filename,Filenewname) 拷贝文件，需要　fso支持 参数：Filename 预拷贝文件的相对路径，Filenewname 拷贝目标名 '********************************************************************// Function PubCopyFile(Filename,Filenewname)    Dim fso,f    if Filename<>"" and Filenewname<>"" then    Filename=Server.MapPath(Filename)    Filenewname=Server.MapPath(Filenewname)    Set fso = server.CreateObject("Scripting.FileSystemObject")       Set f = fso.GetFile(Filename)    f.Copy Filenewname,true    set fso = nothing    set f = nothing    PubCopyFile="Suc"    end if  End Function '//******************************************************************** ' PubSetFolder(Foldername) 新建目录，需要　fso支持 参数：Foldername 目录名称 '********************************************************************// Function PubSetFolder(Foldername)    Dim fso    if Foldername<>"" then    Foldername=Server.MapPath(Foldername)    Set fso = server.CreateObject("Scripting.FileSystemObject")      if fso.FolderExists(Foldername)=false then     fso.CreateFolder Foldername    end if    set fso = nothing    PubSetFolder="Suc"    end if  End Function '/******************************************************************** ' PubEditXml(xmlName,Rootsite,Rootsitesn,texts) 修改某xml一条数据，参数：xmlName 文件名称，Rootsite 指定选取的父节点，Rootsitesn 要依次更新的子节点号(整数)列表（用“|”分割），texts 赋值内容列表（以 “/$/”分割） '********************************************************************/ Sub PubEditXml(xmlName,Rootsite,Rootsitesn,texts) Dim fso  if xmlName<>"" then   xmlName=Server.MapPath(xmlName)  '获取XML文件的路径这里根据虚拟目录不同而不同   Set fso = server.CreateObject("Scripting.FileSystemObject")   if fso.FileExists(xmlName) then   '如果文件存在，则继续 ...   Dim strSourceFile,objXML,objRootsite,texti,textss,Rootsitesns,Rootsitesni   strSourceFile = xmlName     Set objXML =Server.CreateObject("Microsoft.XMLDOM")  '创建一个XML对像   objXML.load(strSourceFile)  '把XML文件读入内存    Set objRootsite = objXML.documentElement.selectSingleNode(rootsite)    textss=split(texts&"/$/","/$/")    texti=0   Rootsitesns=split(Rootsitesn&"|","|")     For Rootsitesni=0 to ubound(Rootsitesns)-1   objRootsite.childNodes.item(Rootsitesns(Rootsitesni)).text=textss(texti)     texti=texti+1   Next       objXML.save(strSourceFile)   Set objXML =nothing  '' 释放 fso  Set fso = nothing end if end if end sub '/******************************************************************** ' PubNewXml(xmlName,Rootsite,Rootsitesn,texts,Indexsite) 新增 xml一条数据，参数：xmlName 文件名称，Rootsite 指定选取的父节点，Indexsite 新增内容主节点，Rootsitesn 要依次新增的子节点名列表（用“|”分割），texts 赋值内容列表（以 “/$/”分割） '********************************************************************/ Sub PubNewXml(xmlName,Rootsite,Rootsitesn,texts,Indexsite) Dim fso Dim brstr:brstr=chr(13)&chr(10)&chr(9)  '规范 XML 样式  if xmlName<>"" then   xmlName=Server.MapPath(xmlName)  '获取XML文件的路径这里根据虚拟目录不同而不同   Set fso = server.CreateObject("Scripting.FileSystemObject")   if fso.FileExists(xmlName) then   '如果文件存在，则继续 ...   Dim strSourceFile,objXML,objRootsite,texti,textss,Rootsitesns,Rootsitesni,XMLnode   strSourceFile = xmlName     Set objXML =Server.CreateObject("Microsoft.XMLDOM")  '创建一个XML对像   objXML.load(strSourceFile)  '把XML文件读入内存    Set objRootsite = objXML.documentElement.selectSingleNode(rootsite)            '根据得到的数据循环个节点名、值建立XML片段         XMLnode=brstr&"<"&Indexsite&">"                            textss=split(texts&"/$/","/$/")            texti=0           Rootsitesns=split(Rootsitesn&"|","|")             For Rootsitesni=0 to ubound(Rootsitesns)-1           XMLnode=XMLnode&brstr&"<"&Rootsitesns(Rootsitesni)&">"&textss(texti)&"</"&Rootsitesns(Rootsitesni)&">"           texti=texti+1           Next        XMLnode=XMLnode&brstr&"</"&Indexsite&">"&brstr               Dim objXML2,rootNewNode       set objXML2=Server.CreateObject("Microsoft.XMLDOM")    '建立一个新XML对像       objXML2.loadXML(XMLnode)     '把XML版片段读入内存中        set rootNewNode=objXML2.documentElement    '获得objXML2的根节点        objRootsite.appendChild(rootNewNode)    '把XML片段插入    objXML.save(strSourceFile)   Set objXML =nothing  '' 释放 fso  Set fso = nothing end if end if end sub '//******************************************************************** '  PubcSize(tSize) KB、MB、GB  单位转换函数 '********************************************************************// function PubcSize(tSize)     if tSize>=1073741824 then         PubcSize=Round(int((tSize/1073741824)*1000)/1000,2) & " GB"     elseif tSize>=1048576 then         PubcSize=Round(int((tSize/1048576)*1000)/1000,2) & " MB"     elseif tSize>=1024 then         PubcSize=Round(int((tSize/1024)*1000)/1000,2) & " KB"     else         PubcSize=Round(tSize,2) & "B"     end if end function '//******************************************************************** '  PubIfzhengshu(shu) 判断是否为正整数 ， 参数：shu 要判断的数字 '********************************************************************// function PubIfzhengshu(shu)     PubIfzhengshu="yes"     Dim shus,shui     shus=split(shu,"")     for shui=0 to Ubound(shus)         if isnumeric(shus(shui))=false then     PubIfzhengshu="no"         exit function     end if     next end function    '/******************************************************************** ' PubPageGs() 格式化分页， rssum 总数，nummer 每页数目，page 当前页码 '********************************************************************/   Sub PubPageGs()     if rssum mod nummer > 0 then       thepages=rssum\nummer+1     else       thepages=rssum\nummer     end if     page=trim(request("page"))     if not(isnumeric(page)) then page=1     if int(page)>int(thepages) or int(page)<1 then       viewpage=1     else       viewpage=int(page)     end if   end Sub '//******************************************************************** '  PubPage1(maxpage,thepages,viewpage,pageurl,pp,font_color) 通用分页函数 (1) '  maxpage,thepages,viewpage,pageurl 链接地址前缀,pp,font_color 显示字体色 '********************************************************************//   Function PubPage1(maxpage,thepages,viewpage,pageurl,pp,font_color)     dim pn,pi,page_num,ppp,pl,pr:pi=1     ppp=pp\2     if pp mod 2 = 0 then ppp=ppp-1     pl=viewpage-ppp     pr=pl+pp-1     if pl<1 then       pr=pr-pl+1:pl=1       if pr>thepages then pr=thepages     end if     if pr>int(thepages) then       pl=pl+thepages-pr:pr=thepages       if pl<1 then pl=1     end if   if pl>1 then     PubPage1=PubPage1&" <a href='"& pageurl &"' title='第一页'>[|<]</a> " & _         " <a href='"& pageurl &"page="&pl-1&"' title='上一页'>[<]</a> "   end if   for pi=pl to pr     if cint(viewpage)=cint(pi) then       PubPage1=PubPage1&" <font color=" & font_color & ">[" & pi & "]</font> "     else       PubPage1=PubPage1&" <a href='"& pageurl &"page="& pi &"' title='第 " & pi & " 页'>[" & pi & "]</a> "     end if   next   if pr<thepages then     PubPage1=PubPage1&" <a href='"& pageurl &"page="&pi&"' title='后一页'>[>]</a> " & _            " <a href='"& pageurl &"page="& thepages &"' title='最后一页'>[>|]</a> "   end if   end function    '//******************************************************************** '  PubPage2(viewpage,thepages,pageurl) 通用分页函数 (2) '  maxpage,thepages,viewpage,pageurl 链接地址前缀 '********************************************************************// Function PubPage2(viewpage,thepages,pageurl)   dim re_color,pf0,pf1,pf2,pf3,pf4,pf5   re_color="#c0c0c0"   pf0="已是第一页"   pf1="第一页"   pf2="上一页"   pf3="下一页"   pf4="最后一页"   pf5="已是最后一页"   PubPage2=VbCrLf & "<table border=0 cellspacing=0 cellpadding=0><tr><form action='"&pageurl&"' method=post><td>"   if cint(viewpage)=1 then     PubPage2=PubPage2 & VbCrLf & "<font color="&re_color&">"&pf0&"</font> "   else     PubPage2=PubPage2 & VbCrLf & "<a href='"&pageurl&"page=1' alt='"&pf1&"'>"&pf1&"</a>┋<a href='"&pageurl&"page="&cint(viewpage)-1&"' alt='"&pf2&"'>"&pf2&"</a> "   end if   if cint(viewpage)=cint(thepages) then     PubPage2=PubPage2 & VbCrLf & "<font color="&re_color&" alt='"&pf5&"'>"&pf5&"</font>"   else     PubPage2=PubPage2 & VbCrLf & "<a href='"&pageurl&"page="&cint(viewpage)+1&"' alt='"&pf3&"'>"&pf3&"</a>┋<a href='"&pageurl&"page="&cint(thepages)&"' alt='"&pf4&"'>"&pf4&"</a>"   end if   if cint(thepages)<>1 then     PubPage2=PubPage2 & VbCrLf & " <input type=text name=page value='"&viewpage&"' size=2> <input type=submit value='GO'>"   end if   PubPage2=PubPage2 & VbCrLf & "</td></form></tr></table>" end Function '//******************************************************************************** '  Pubobject_install(strclassstring) 组件判断函数 值为 true 时 说明服务器支持该组件 '  参数：strclassstring  组件标示 '**********************************************************************************//   function Pubobject_install(strclassstring)   on error resume next   Pubobject_install=false   dim xtestobj   err=0   set xtestobj=server.createobject(strclassstring)   if err=0 then Pubobject_install=true   set xtestobj=nothing   err=0   end function %>