复制代码 代码如下:<%
"///******************************************************************
" 常用公共函数库 文件名：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
ummer+1
else
thepages=rssum
ummer
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=pp2
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
%>
易网时代-编程资源站