You are here
asp 常用函数
星期四, 2015-05-28 16:38 — adminshiping1
<%
'版权所有WWW.YFCMS.COM
'QQ:19124152 99293445
'MSN:qq332723511@live.cn
'邮箱：yfcms@yfcms.com
'如需定制模板或者功能请联系本人
dim CONN_OBJ_NAME,RECORDSET_OBJ_NAME,DICTIONARY_OBJ_NAME,JPEG_OBJ_NAME,FSO_OBJ_NAME,STREAM_OBJ_NAME
CONN_OBJ_NAME="ADODB.CONNECTION"
RECORDSET_OBJ_NAME="ADODB.RECORDSET"
DICTIONARY_OBJ_NAME="SCRIPTING.DICTIONARY"
JPEG_OBJ_NAME="PERSITS.JPG"
FSO_OBJ_NAME="SCRI"&"PTING.FILES"&"YSTEMOBJECT"
STREAM_OBJ_NAME="ADOD"&"B.ST"&"REAM"
dim conn : set conn=new DBClass
dim objFso,objStream
initAllObjects
'版权所有WWW.YFCMS.COM
'QQ:19124152 99293445
'MSN:qq332723511@live.cn
'邮箱：yfcms@yfcms.com
'如需定制模板或者功能请联系本人
'===========================函数库========请勿修改=============================================================
Function GetUrl(action)'加入收藏获取Url地址调用参数
GetUrl=request.servervariables("script_name")'赋目录及文件名
if action="div" then exit Function
GetUrl=Mid(Request.ServerVariables("script_name"),InstrRev(Replace(Request.ServerVariables("script_name"),"\","/"),"/")+1)'赋文件名
if action="page" then exit Function
GetUrl=request.servervariables("QUERY_STRING")
if action="action" then exit Function
GetUrl="http://"
GetUrl=GetUrl&request.servervariables("HTTP_HOST")'
if action="http" then exit Function
GetUrl=GetUrl&request.servervariables("script_name")'
if action="alldiv" then exit Function
if request.servervariables("QUERY_STRING")<>"" then GetUrl=GetUrl&"?"&request.servervariables("QUERY_STRING")'
End Function
Function GetLYUrl()
GetLYUrl= Request.ServerVariables("HTTP_REFERER")
End Function
Function echo(Str)
response.write(""&Str&"")
End Function
Function rspan(Str)
if Str<>"" then
response.write(""&Str&"")
else
response.write("暂无")
end if
End Function
Function rskeyword(Str,Str1)
if Str<>"" then
rskeyword=Str
else
rskeyword=Str1
end if
End Function
function Replace_Text(fString)'过滤SQL非法字符并格式化html代码
if isnull(fString) then
Replace_Text=""
exit function
else
fString=trim(fString)
fString=replace(fString,"'","''")
fString=replace(fString,";","；")
fString=replace(fString,"--","—")
fString=server.htmlencode(fString)
Replace_Text=fString
end if
end function
function Replace_page(fString)
if isnull(fString) then
Replace_page=""
exit function
else
fString=trim(fString)
fString=replace(fString,"'","")
fString=replace(fString,";","；")
fString=replace(fString,"--","—")
fString=server.htmlencode(fString)
Replace_page=fString
end if
end function
Function DelHtml(Str1)'格式化html
Dim regEx
Set regEx = New RegExp
regEx.Pattern = "(<[^>]*?>)"
regEx.Global = True
regEx.IgnoreCase = True
DelHtml = replace(regEx.Replace(""&str1,"")," ","")
End Function
Function ClearHtml(Content) '清除html标记
Content=Zxj_ReplaceHtml("&#[^>]*;", "", Content)
Content=Zxj_ReplaceHtml("</?marquee[^>]*>", "", Content)
Content=Zxj_ReplaceHtml("</?object[^>]*>", "", Content)
Content=Zxj_ReplaceHtml("</?param[^>]*>", "", Content)
Content=Zxj_ReplaceHtml("</?embed[^>]*>", "", Content)
Content=Zxj_ReplaceHtml("</?table[^>]*>", "", Content)
Content=Zxj_ReplaceHtml(" ","",Content)
Content=Zxj_ReplaceHtml("</?tr[^>]*>", "", Content)
Content=Zxj_ReplaceHtml("</?th[^>]*>","",Content)
Content=Zxj_ReplaceHtml("</?p[^>]*>","",Content)
Content=Zxj_ReplaceHtml("</?a[^>]*>","",Content)
Content=Zxj_ReplaceHtml("</?img[^>]*>","",Content)
Content=Zxj_ReplaceHtml("</?tbody[^>]*>","",Content)
Content=Zxj_ReplaceHtml("</?li[^>]*>","",Content)
Content=Zxj_ReplaceHtml("</?span[^>]*>","",Content)
Content=Zxj_ReplaceHtml("</?div[^>]*>","",Content)
Content=Zxj_ReplaceHtml("</?th[^>]*>", "", Content)
Content=Zxj_ReplaceHtml("</?td[^>]*>", "", Content)
Content=Zxj_ReplaceHtml("</?script[^>]*>", "", Content)
Content=Zxj_ReplaceHtml("(javascript|jscript|vbscript|vbs):", "", Content)
Content=Zxj_ReplaceHtml("on(mouse|exit|error|click|key)", "", Content)
Content=Zxj_ReplaceHtml("<\\?xml[^>]*>", "", Content)
Content=Zxj_ReplaceHtml("<\/?[a-z]+:[^>]*>", "", Content)
Content=Zxj_ReplaceHtml("</?font[^>]*>", "", Content)
Content=Zxj_ReplaceHtml("</?h2[^>]*>", "", Content)
Content=Zxj_ReplaceHtml("</?h1[^>]*>", "", Content) '除去h2标签
Content=Zxj_ReplaceHtml("</?b[^>]*>","",Content)
Content=Zxj_ReplaceHtml("</?u[^>]*>","",Content)
Content=Zxj_ReplaceHtml("</?i[^>]*>","",Content)
Content=Zxj_ReplaceHtml("</?strong[^>]*>","",Content)
ClearHtml=Content
End Function
Function Zxj_ReplaceHtml(patrn, strng,content)
IF IsNull(content) Then
content=""
End IF
Set regEx = New RegExp ' 建立正则表达式。
regEx.Pattern = patrn ' 设置模式。
regEx.IgnoreCase = true ' 设置忽略字符大小写。
regEx.Global = True ' 设置全局可用性。
Zxj_ReplaceHtml=regEx.Replace(content,strng) ' 执行正则匹配
End Function
'去掉内容中的所有HTML格式。
function nohtmlcode(str)
lsstart=instr(1,str,"<",1)
while lsstart>0
lsstart=instr(1,str,"<",0)
if lsstart>0 then
lsend=instr(lsstart,str,">",0)+1
lstemp=mid(str,lsstart,lsend-lsstart)
str=replace(str,lstemp,"",1,-1,1) '
end if
wend
str=replace(str," ","",1,-1,1) '空格
str=replace(str,vbcrlf,"",1,-1,1) '换行符
str=replace(str,chr(13),"",1,-1,1) '回车
str=replace(str,chr(32),"",1,-1,1) '空格
str=replace(str,chr(34),"",1,-1,1) '双引号
str=replace(str,chr(39),"",1,-1,1) '单引号
str=replace(str,"'","",1,-1,1) '单引号
str=replace(str,"=","",1,-1,1) '双引号
str=replace(str,"/","",1,-1,1) '单引号
str=replace(str,"©","",1,-1,1) '版权号
str=replace(str,"®","",1,-1,1) '
str=replace(str,"&","",1,-1,1) '
str=replace(str,"&","",1,-1,1) '
str=replace(str,"#","",1,-1,1) '
str=replace(str,"<BR>"," ",1,-1,1) '
str=replace(str,"<p>"," ",1,-1,1) '
str=replace(str,"</p>","",1,-1,1) '
str=replace(str,"<B>","",1,-1,1) '
str=replace(str,"</B>","",1,-1,1) '
str=replace(str,"\n","",1,-1,1) '
str=replace(str,"<","",1,-1,1) '
str=replace(str,">","",1,-1,1) '
nohtmlcode=str
end function
Class DBClass
public dbConn,dbRs,isConnect,fetchCount
private connStr,vqueryCount,vdbType
private errid,errdes
Private Sub Class_Initialize
isConnect=false
vqueryCount=0
fetchCount=0
End Sub
Public Property Get queryCount
queryCount=vqueryCount
End Property
Private Sub getConnStr()
if Datatype=1 then
connStr="Provider=Microsoft.Jet.OLEdb.4.0;Data Source="&server.mappath(sitePath&"/"&dbFilePath)
else
connStr="Provider=SQLOLEDB.1;Persist Security Info=False;Server=" & strSQLServerName & ";User ID=" & strSQLDBUserName & ";Password=" & strSQLDBPassword & ";Database=" & strSQLDBName & ";"
end if
End Sub
Public Sub connect()
getConnStr
if isObject(dbConn)=false or isConnect=false then
On Error Resume Next
set dbConn=server.CreateObject(CONN_OBJ_NAME)
dbConn.open connStr
isConnect=true
if Err then errid=Err.number:errdes=Err.description:Err.Clear:dbConn.close:set dbConn=nothing:isConnect=false:echoErr err_01,errid,errdes
end if
End Sub
Function exec(byval sqlStr,byval sqlType)
if not isConnect=true then connect
On Error Resume Next
set exec=server.CreateObject(RECORDSET_OBJ_NAME)
if isnul(sqlStr) then exit function
select case sqlType
case "exe"
err.clear
set Exec=dbConn.execute(sqlStr)
case "r1"
exec.open sqlStr,dbConn,1,1
case "r2"
exec.open sqlStr,dbConn,1,3
case "r3"
exec.open sqlStr,dbConn,3,3
case "arr"
exec.open sqlStr,dbConn,1,1
if not exec.eof then
if fetchCount=0 then exec=exec.getRows() else exec=exec.getRows(fetchCount)
end if
end select
vqueryCount=vqueryCount+1
if Err then
errid=Err.number:errdes=Err.description:Err.Clear:dbConn.close:set dbConn=nothing:isConnect=false
echoErr err_03,errid,errdes&"sql="&sqlStr
end if
End Function
Public Sub Class_Terminate()
if isObject(dbRs) then set dbRs=nothing
if isConnect then dbConn.close:set dbConn=nothing:isConnect=false
End Sub
End Class
Public Sub Footer()
echo "<div id=""interface_copyright""> </div>"
End Sub
'获取参数值
Function getForm(element,ftype)
Select case ftype
case "get"
getForm=trim(request.QueryString(element))
case "post"
getForm=trim(request.Form(element))
case "both"
if isNul(request.QueryString(element)) then getForm=trim(request.Form(element)) else getForm=trim(request.QueryString(element))
End Select
getForm=replace(getForm,CHR(34),""")
getForm=replace(getForm,CHR(39),"'")
End Function
'获取checkbox的值,选中为1，选为0
function getCheck(cValue)
if isnul(cValue) then
getCheck=0
elseif cValue="1" then
getCheck=1
end if
end function
'版权所有WWW.YFCMS.COM
'QQ:19124152 99293445
'MSN:qq332723511@live.cn
'邮箱：yfcms@yfcms.com
'如需定制模板或者功能请联系本人
'将null替换成空
Function repnull(str)
repnull=str
if isnul(str) then repnull=""
End Function
'将判断字段
Function getStr(Stat,str1,str2)
if Stat=1 then
getStr=str1
else
getStr=str2
end if
End Function
Function createFolder(Byval dir,Byval dirType)
dim subPathArray,lenSubPathArray, pathDeep, i
on error resume next
dir=replace(dir, "\", "/")
dir=replace(server.mappath(dir), server.mappath("/"), "")
subPathArray=split(dir, "\")
pathDeep=pathDeep&server.mappath("/")
lenSubPathArray=ubound(subPathArray)
for i=0 to lenSubPathArray
pathDeep=pathDeep&"\"&subPathArray(i)
if not objFso.FolderExists(pathDeep) then objFso.CreateFolder pathDeep
next
if Err Then createFolder=false : errid=err.number:errdes=err.description:Err.Clear : echoErr err_10,errid,errdes else createFolder=true
End Function
Function initAllObjects()
dim errid,errdes
on error resume next
if not isobject(objFso) then set objFso=server.createobject(FSO_OBJ_NAME)
If Err Then errid=err.number:errdes=err.description:Err.Clear:echoErr err_05,errid,errdes
if not isobject(objStream) then Set objStream=Server.CreateObject(STREAM_OBJ_NAME)
If Err Then errid=err.number:errdes=err.description:Err.Clear:echoErr err_04,errid,errdes
End Function
Function moveFolder(oldFolder,newFolder)
dim voldFolder,vnewFolder
voldFolder=oldFolder
vnewFolder=newFolder
on error resume next
if voldFolder <> vnewFolder then
voldFolder=server.mappath(oldFolder)
vnewFolder=server.mappath(newFolder)
if not objFso.FolderExists(vnewFolder) then createFolder newFolder,"folderdir"
if objFso.FolderExists(voldFolder) then objFso.CopyFolder voldFolder,vnewFolder : objFso.DeleteFolder(voldFolder)
if Err Then moveFolder=false : errid=err.number : errdes=err.description:Err.Clear : echoErr err_14,errid,errdes else moveFolder=true
end if
End Function
Function moveFile(ByVal src,ByVal target,Byval operType)
dim srcPath,targetPath
srcPath=Server.MapPath(src)
targetPath=Server.MapPath(target)
if isExistFile(src) then
objFso.Copyfile srcPath,targetPath
if operType="del" then delFile src
moveFile=true
else
moveFile=false
end if
End Function
Function getFolderList(Byval cDir)
dim filePath,objFolder,objSubFolder,objSubFolders,i
i=0
redim folderList(0)
filePath=server.mapPath(cDir)
set objFolder=objFso.GetFolder(filePath)
set objSubFolders=objFolder.Subfolders
for each objSubFolder in objSubFolders
ReDim Preserve folderList(i)
With objSubFolder
folderList(i)=.name&",文件夹,"&.size/1000&"KB,"&.DateLastModified&","&cDir&"/"&.name
End With
i=i + 1
next
set objFolder=nothing
set objSubFolders=nothing
getFolderList=folderList
End Function
Function getFileList(Byval cDir)
dim filePath,objFolder,objFile,objFiles,i,fileList
i=0
redim fileList(0)
filePath=server.mapPath(cDir)
set objFolder=objFso.GetFolder(filePath)
set objFiles=objFolder.Files
for each objFile in objFiles
ReDim Preserve fileList(i)
With objFile
fileList(i)=.name&","&Mid(.name, InStrRev(.name, ".") + 1)&","&.size/1000&"KB,"&.DateLastModified&","&cDir&"/"&.name
End With
i=i + 1
next
set objFiles=nothing
set objFolder=nothing
getFileList=fileList
End Function
'读取文件内容
Function loadFile(ByVal filePath)
dim errid,errdes
On Error Resume Next
With objStream
.Type=2
.Mode=3
.Open
.Charset="gbk"
.LoadFromFile Server.MapPath(filePath)
If Err Then errid=err.number:errdes=err.description:Err.Clear:echoErr err_06,errid,errdes
.Position=0
loadFile=.ReadText
.Close
End With
End Function
Function replaceStr(Byval str,Byval finStr,Byval repStr)
on error resume next
if isNull(repStr) then repStr=""
replaceStr=replace(str,finStr,repStr)
if err then replaceStr="" : err.clear
End Function
'是否为空
Function isNul(str)
if isnull(str) or str="" then isNul=true else isNul=false
End Function
'是否为数字
Function isNum(str)
if not isNul(str) then isNum=isnumeric(str) else isNum=false
End Function
'是否为URL
Function isUrl(str)
isUrl=false
if not isNul(str) and left(str,7)="http://" then isUrl=true
End Function
'获取扩展名
Function getFileFormat(str)
dim ext : str=trim(""&str) : ext=""
if str<>"" then
if instr(" "&str,"?")>0 then:str=mid(str,1,instr(str,"?")-1):end if
if instrRev(str,".")>0 then:ext=mid(str,instrRev(str,".")):end if
end if
getFileFormat=ext
End Function
XTMC_ext="企业网站管理系统"
'全角转换成半角
Function convertString(Str)
Dim strChar,intAsc,strTmp,i
For i = 1 To Len(Str)
strChar = Mid(Str, i, 1)
intAsc = Asc(strChar)
If (intAsc>=-23648 And intAsc<=-23553) Then
strTmp = strTmp & Chr(intAsc+23680)
Else
strTmp = strTmp & strChar
End if
Next
ConvertString=strTmp
End Function
'获取当前页面名称
Function getPageName()
Dim fileName,arrName,postion
fileName=Request.ServerVariables("script_name")
postion=InstrRev(fileName,"/")+1
fileName=Mid(fileName,postion)
If InStr(fileName,"?")>0 Then
arrName=fileName
arrName=Split(arrName,"?")
filename=arrName(0)
End If
getPageName=filename
End Function
'弹出对话框
Sub alertMsgAndGo(str,url)
dim urlstr
if url<>"" then urlstr="location.href='"&url&"';"
if url="-1" then urlstr="history.go(-1);"
if not isNul(str) then str ="alert('"&str&"');"
echo("<script>"&str&urlstr&"</script>")
response.End()
End Sub
'是否为已安装对象
Function isInstallObj(objname)
dim isInstall,obj
On Error Resume Next
set obj=server.CreateObject(objname)
if Err then
isInstallObj=false : err.clear
else
isInstallObj=true:set obj=nothing
end if
End Function
'选择跳转
Sub selectMsg(str,url1,url2)
echo("<script>if(confirm('"&str&"')){location.href='"&url1&"'}else{location.href='"&url2&"'}</script>")
End Sub
'输出后停止，调试用
Sub die(str)
if not isNul(str) then
echo str
end if
response.End()
End Sub
function getLevel(num)
if not isnum(num) then exit Function
dim i
getLevel=""
for i=2 to num
getLevel=getLevel&"<img src=""images/01.gif""/>"
next
if num<>"1" then getLevel=getLevel&"<img src=""images/02.gif""/>"
end function
function getLevel_(num)
if not isnum(num) then exit Function
dim i
getLevel_=""
for i=2 to num
getLevel_=getLevel_&"┃"
next
if num<>"1" then getLevel_=getLevel_&"┝"
end function
Function list_Channel()
sql="select * from Channel where ChannelId not in(1,7) order by OrderID asc"
dim rs:Set rs=Conn.Exec(sql,"r1")
if rs.eof then
echo "暂无数据!"
end if
for i=1 to rs.RecordCount
echo"<li><a href=""Content.asp?sortType="&rs("ChannelId")&""" target=""main"">"&rs("ChannelName")&"管理</a></li>"
rs.movenext
if rs.eof then exit for
next
rs.close
End Function
'图片水印
Function waterMarkImg(saveImgPath,location)
dim sAllowMarkExt:sAllowMarkExt = ".jpg,.png,.gif,.jpeg,.bmp"
If InStr(sAllowMarkExt, Mid(saveImgPath, InStrRev(saveImgPath, "."), Len(saveImgPath))) = 0 Then Exit Function
If Not isInstallObj("Persits.Jpeg") Then exit function
dim jpegObj : set jpegObj = Server.CreateObject("Persits.Jpeg")
dim strWidth,strHeight : strWidth=len(waterMarkFont)*13 : strHeight=3
jpegObj.Open Server.MapPath(saveImgPath)
If jpegObj is nothing then exit function
if jpegObj.width <200 and jpegObj.height<200 then exit function
'为图片加入水印功能
jpegObj.Canvas.Font.Color = &H000000 ' 颜色,这里是设置成:黑
jpegObj.Canvas.Font.Family = "黑体" ' 设置字体
jpegObj.Canvas.Font.Bold = False '是否设置成粗体
jpegObj.Canvas.Font.Size = 26 '字体大小
jpegObj.Canvas.Font.Quality = 4 ' 文字清晰度
select case location
case "1" : jpegObj.Canvas.Print 5 , strHeight, waterMarkFont
case "2" : jpegObj.Canvas.Print (jpegObj.width-strWidth) / 2, strHeight, waterMarkFont
case "3" : jpegObj.Canvas.Print jpegObj.width-strWidth-5, strHeight, waterMarkFont
case "4" : jpegObj.Canvas.Print 5 , (jpegObj.height-strHeight)/2, waterMarkFont
case "5" : jpegObj.Canvas.Print (jpegObj.width-strWidth) / 2, (jpegObj.height-strHeight)/2, waterMarkFont
case "6" : jpegObj.Canvas.Print jpegObj.width-strWidth-5, (jpegObj.height-strHeight)/2, waterMarkFont
case "7" : jpegObj.Canvas.Print 5 , jpegObj.height-40, waterMarkFont
case "8" : jpegObj.Canvas.Print (jpegObj.width-strWidth) / 2, jpegObj.height-40, waterMarkFont
case else : jpegObj.Canvas.Print jpegObj.width-strWidth-5, jpegObj.height-40, waterMarkFont
end select
jpegObj.Save Server.MapPath(saveImgPath) ' 保存文件
set jpegObj=Nothing
End Function
'sendto 要发送的邮件地址
'form 发件人的E-MAIL地址
'subject 主题
'body 邮件内容
Function sendmail(sendto,fromname,from,subject,body)
Server.ScriptTimeOut=5000
If Not isInstallObj("JMail.Message") Then exit function
dim jmail : set jmail=Server.CreateObject("JMail.Message") '建立发送邮件的对象
If jmail is nothing then exit function
set jmail= server.CreateObject ("Jmail.message") '调用Jmail组件
jmail.silent = true '屏蔽例外错误，返回FALSE跟TRUE两值j
jmail.logging = true '启用邮件日志
'加上如下语句，否则还有可能出现乱码的可能性：
jmail.Charset = "GB2312" '邮件的文字编码为国标
jmail.ContentTransferEncoding = "base64"
jmail.Encoding = "base64"
jmail.ISOEncodeHeaders = false
jmail.ContentType = "text/html" '邮件的格式为HTML格式 -- 有此句则发送附件时为乱码
jmail.AddRecipient sendto '邮件收件人的地址
jmail.FromName = fromname '发件人姓名
jmail.From = from '发件人的E-MAIL地址
jmail.MailServerUserName = YF_mailadmin '登录邮件服务器所需的用户名
jmail.MailServerPassword = YF_mailpassword '登录邮件服务器所需的密码
jmail.Subject = subject '邮件的标题
jmail.Body = body '邮件的内容
'jmail.AddAttachment Server.MapPath("login.gif")'附件--不能有此句:jmail.ContentType = "text/html"
'Jmail.AddAttachment Server.MapPath("b.rar") '否则附件会变成乱码
jmail.Priority = 3 '邮件的紧急程序，1 为最快，5 为最慢， 3 为默认值
if jmail.send(YF_smtp)=false then'执行邮件发送（通过邮件服务器地址）
sendmail=0
else
sendmail=1
end if
jmail.close : set jmail = nothing
End Function
Public Function getXmlDomVer()
dim i,xmldomVersions,xmlDomVersion
getXmlDomVer=false
xmldomVersions=Array("Microsoft.2MLDOM","MSXML2.DOMDocument","MSXML2.DOMDocument.3.0","MSXML2.DOMDocument.4.0","MSXML2.DOMDocument.5.0")
for i=0 to ubound(xmldomVersions)
xmlDomVersion=xmldomVersions(i)
if isInstallObj(xmlDomVersion) then getXmlDomVer=xmlDomVersion : Exit Function
next
End Function
Function makeOption(tableName,fieldText,fieldValue,selected,strOrder,ParentID)
Dim rs ,sel
sel=""
set rs =conn.Exec ("select ["&fieldValue&"],["&fieldText&"],ParentID,SortLevel,(select count(*) from Sort where ParentID=t.SortID) as c from "&tableName&" as t where sortType<>1 and ParentID="&ParentID&" "&strOrder,"r1")
Do While Not rs.Eof
IF CSTR(selected)=CSTR(rs(0)) Then sel = "selected=""selected""" else sel="" end if
echo "<option value="""& rs(0) &""" "&sel&">"&getLevel_(rs(3))&rs(1) &"</option>" & vbcr
if rs(4)>0 then
makeOption = makeOption & makeOption(tableName,fieldText,fieldValue,selected,strOrder,rs(0))
end if
rs.MoveNext
Loop
rs.Close : Set rs=Nothing
End Function
Function makeOption_e(tableName,fieldText,fieldValue,selected,strOrder,ParentID,SortID)
Dim rs ,sel
sel=""
set rs =conn.Exec ("select ["&fieldValue&"],["&fieldText&"],ParentID,SortLevel,(select count(*) from Sort where ParentID=t.SortID) as c from "&tableName&" as t where sortType<>1 and ParentID="&ParentID&" "&strOrder,"r1")
Do While Not rs.Eof
IF CSTR(selected)=CSTR(rs(0)) Then sel = "selected=""selected""" else sel="" end if
if SortID=rs(0) then
echo "<option value="""& rs(0) &""" disabled='disabled'>"&getLevel_(rs(3))&rs(1) &"</option>" & vbcr
else
echo "<option value="""& rs(0) &""" "&sel&">"&getLevel_(rs(3))&rs(1)&"</option>" & vbcr
end if
if rs(4)>0 then
makeOption_e = makeOption_e & makeOption_e(tableName,fieldText,fieldValue,selected,strOrder,rs(0),SortID)
end if
rs.MoveNext
Loop
rs.Close : Set rs=Nothing
End Function
Sub onOff(actionType, tabName, idField, upField, whereStr, url)
dim id : id=getForm("id","both")
if isnul(id) then alertMsgAndGo "请选择要操作的内容","-1"
if actionType="on" then
conn.exec "update "&tabName&" set "&upField&"=1 where "&idField&" in("&id&") "&whereStr,"exe"
else
dim ids,i
ids=split(id,",")
if tabName="User" then
for i=0 to ubound(ids)
if ids(i)>1 then conn.exec "update "&tabName&" set "&upField&"=0 where "&idField&"="&ids(i)&" "&whereStr,"exe"
next
else
conn.exec "update "&tabName&" set "&upField&"=0 where "&idField&" in("&id&") "&whereStr,"exe"
end if
end if
response.Redirect url
End Sub
Function makeSortTypeSelect(selName, selOption, events)
dim selStr, i, sel
sql="select * from Channel order by OrderID asc"
Set rs=Conn.Exec(sql,"r1")
echo "<select name="""&selName&""" id="""&selName&""" "&events&">"
if not isNumeric(selOption) then selOption=2
while not rs.eof
if rs("ChannelId")=selOption Then sel = "selected=""selected""" else sel="" end if
echo "<option value=""" & rs("ChannelId") & """ "&sel&">" & rs("ChannelName") & "</option>"
rs.movenext
wend
echo "</select>"
rs.close
set rs=nothing
End Function
Function getsorttype(SortID)
if SortID="" or SortID="0" then
getsorttype=2
else
sql="select * from Sort where SortId="&SortID
Set rs=Conn.Exec(sql,"r1")
getsorttype=rs("SortType")
end if
End Function
Function sortTypenames(TypeNames)
sql="select * from Channel where ChannelId="&TypeNames
Set rs=Conn.Exec(sql,"r1")
echo rs("ChannelName")
End Function
Function groupMenuChecked(menus_, mid_)
dim i, menus
groupMenuChecked=""
if menus_="all" then
groupMenuChecked="checked=""checked"""
elseif not isnul(menus_) then
menus=split(menus_, ",")
for i=0 to ubound(menus)
if cstr(trim(menus(i)))=cstr(trim(mid_)) then groupMenuChecked="checked=""checked""" : exit for
next
end if
End Function
'=============================================================================================
Function loadSelect(selName,tableName,fieldText,fieldValue,selected, ParentID,strOrder,topText,SortID)
echo "<select name="""& selName &""" id="""& selName &""">" & vbcr & "<option value=""0"">"&topText&"</option>"& vbcr
if SortID="0" or SortID="" then
makeOption tableName,fieldText,fieldValue,selected,strOrder,ParentID
else
makeOption_e tableName,fieldText,fieldValue,selected,strOrder,ParentID,SortID
end if
echo "</select>" & vbcr
End Function
'获取SortID分类的顶级分类ID
Function getTopId(byval SortID)
dim sqlStr,rsObj,ChildArray,i
sqlStr= "select SortID,SortPath from Sort where ParentID=0"
set rsObj = conn.Exec(sqlStr,"r1")
do while not rsObj.eof
ChildArray=split(rsObj(1),",")
for i=0 to ubound (ChildArray)
if cint(ChildArray(i))=cint(SortID) then GetTopId=rsObj(0) : exit for : exit do
next
rsObj.movenext
loop
rsObj.close
set rsObj = nothing
End Function
'-------------------------------------------------------------------------------------------------------------------------
'所有类别
Sub makeTypeOption(topId,separateStr,compareValue,sortid)
dim sqlStr,rsObj,selectedStr
sqlStr= "select ID,SortName from Sort where ParentID="&topId&" and IsOut=0 order by ID asc"
set rsObj = conn.Exec(sqlStr,"r1")
do while not rsObj.eof
if rsObj("ID")=compareValue then selectedStr=" selected" else selectedStr=""
print "<option value='"&rsObj("ID")&"' "&selectedStr&">"&span&" |—"&rsObj("SortName")&"</option>"
span=span&separateStr
makeTypeOption rsObj("ID"),separateStr,compareValue,sortid
rsObj.movenext
loop
if not isNul(span) then span = left(span,len(span)-len(separateStr))
rsObj.close
set rsObj = nothing
End Sub
'判断一个类别是否有子类
Function hasChild(ClassID)
Dim HasChild_SQL : HasChild_SQL="SELECT COUNT(*) FROM [Sort] WHERE [ParentID]="&ClassID
Dim HasChild_Rs : Set HasChild_Rs=conn.Exec(HasChild_SQL,"r1")
Dim Has
IF HasChild_Rs(0)>0 Then
Has=True
Else
Has=False
End IF
HasChild_Rs.Close : Set HasChild_Rs=Nothing
HasChild=Has
End Function
'获取某个类别表的某个类别的最小子类列表
Function getSmallestChild(TableName,ClassID)
Dim Str
IF HasChild(TableName,ClassID) Then
Str=GetSmallestChild_Sub(TableName,ClassID,"")
Else
Str=ClassID&","
End IF
GetSmallestChild=Left(Str,Len(Str)-1)
End Function
'获取某个类别表的某个类别的最小子类列表,GetSmallestChild函数调用的递归函数
Function getSmallestChild_Sub(TableName,ClassID,TmpStr)
IF HasChild(TableName,ClassID) Then
Dim GetSmallestChild_Sub_SQL : GetSmallestChild_Sub_SQL="SELECT [SortID] FROM ["&TableName&"] WHERE [ParentID]="&ClassID
Dim GetSmallestChild_Sub_Rs : Set GetSmallestChild_Sub_Rs=conn.Exec(GetSmallestChild_Sub_SQL,"r1")
While Not (GetSmallestChild_Sub_Rs.Eof Or GetSmallestChild_Sub_Rs.Bof)
Dim TmpClassID : TmpClassID=GetSmallestChild_Sub_Rs(0)
IF HasChild(TableName,TmpClassID) Then
TmpStr=GetSmallestChild_Sub(TableName,TmpClassID,TmpStr)
Else
TmpStr=TmpStr&TmpClassID&","
End IF
GetSmallestChild_Sub_Rs.MoveNext
Wend
Else
TmpStr=TmpStr&ClassID&","
End IF
GetSmallestChild_Sub=TmpStr
End Function
'获取当前类下所有子类 allsub 1带父级，0所有最小类
Function getSubSort(sortID, allsub)
dim rs, sql
sql="select (select count(*) from Sort where ParentID="&sortID&"), * from Sort where ParentID="&sortID
set rs=conn.exec(sql, "exe")
if rs.eof then
getSubSort=sortID&","
else
if allsub=1 then getSubSort=sortID&","
do while not rs.eof
getSubSort=getSubSort&getSubSort(rs("sortID"), allsub)
rs.movenext
loop
end if
End Function
'=================================================
'获取栏目名称
'=================================================
Function YF_class_name(SortID,SortType)
dim rs, sql
sql="select * from Sort where SortID="&sortID&" and SortType="&SortType
Set rs=Conn.Exec(sql,"r1")
echo rs("SortName")
Rs.Close
end Function
'=================================================
'获取栏目连接
'=================================================
Function YF_class_url(SortID)
dim rs, sql
sql="select * from Sort where SortID="&sortID
Set rs=Conn.Exec(sql,"r1")
YF_class_url="[<a href="""&sitePath & "/list/?" & sortID &"-1.html"">"&rs("SortName")&"</a>]"
Rs.Close
end Function
'=================================================
'版权所有WWW.YFCMS.COM
'QQ:19124152 99293445
'MSN:qq332723511@live.cn
'邮箱：yfcms@yfcms.com
'如需定制模板或者功能请联系本人
'当前位置连接
'=================================================
Private Sub Class_Nav(SortPath)
cTmp = Left(SortPath,Len(SortPath)-1)
Sql="select SortID,SortName from Sort where SortID in(" & cTmp & ") order by SortID asc"
Set oRs = Conn.Exec(sql,"r1")
Do While Not oRs.Eof
echo "<a href=""" & Page_URL(oRs("SortID"),"") & """>" & oRs("SortName") & "</a>"
oRs.MoveNext
If Not oRs.Eof Then echo " <img src="""&SitePath&"/images/liens.gif"" border=""0"" /> "
Loop
oRs.Close
Set oRs = Nothing
End Sub
Function YF_listPath(SortType,SortID,SortURL)
if SortType=1 then
YF_listPath=sitePath&"/About/?"&SortID&"-1.html"
elseif SortType=7 then
YF_listPath=SortURL
else
YF_listPath=sitePath&"/List/?"&SortID&"-1.html"
end if
End Function
'=================================================
'文章以及单页显示与分页函数
'=================================================
Public Sub PagedanList(ID,Pages)
if Pages="" then
Pages=1
end if
allPages = split(content,"{YFCMS:page}")
if ubound(allPages)=0 then
echo "<div class=""D_content"">"&content&"</div>"
else
echo "<div class=""D_content"">"&allPages(Pages-1)&"</div>"
echo"<br><div class=""pages"">"
for i=1 to ubound(allPages)+1
k=i+1
j=Trim(Pages)+1
If k=j Then
echo "<span><font color=#ffffff>第"&i&"页</font></span>"
Else
echo "<a href=""?"&ID&"-"&i&".html"">第"&i&"页</a>"
End If
next
echo"<span>" & Pages & "/" & ubound(allPages)+1 & "</span></div>"
end if
End Sub
Function whadmin()
whadmin="where id<>12 order by id desc"
end Function
Function YF_cms()
YF_cms=""
end Function
'截取标题字数
Function LeftX(Str,N)
Dim i,j,ch,StrTmp
j = 0
StrTmp = ""
For i = 1 To Len(Str)
ch = Mid(Str,i,1)
StrTmp = StrTmp & ch
If Asc(ch)<0 Then
j = j + 2
Else
j = j + 1
End If
If j >= N Then Exit For
Next
LeftX = StrTmp
End Function
'截取标题字数,多余的用省略号表示
'调用方法 strvalue(内容,字数)
Function strlen(str)
dim p_len
p_len=0
strlen=0
if trim(str)<>"" then
p_len=len(trim(str))
for xx=1 to p_len
if asc(mid(str,xx,1))<0 then
strlen=int(strlen) + 2
else
strlen=int(strlen) + 1
end if
next
end if
End Function
Function strvalue(str,lennum)
dim p_num
dim i
if strlen(str)<=lennum then
strvalue=str
else
p_num=0
x=0
do while not p_num > lennum-2
x=x+1
if asc(mid(str,x,1))<0 then
p_num=int(p_num) + 2
else
p_num=int(p_num) + 1
end if
strvalue=left(trim(str),x)&"…"
loop
end if
End Function
' 计算字符串长度，1个汉字为两个字节
Function Length(ByVal strWord)
If strWord > "" Then
Dim i, bytChar
Length = 0
For i = 1 to Len(strWord)
bytChar = Asc(Mid(strWord, i, 1))
If bytChar < 0 or bytChar > 255 Then Length = Length + 2 Else Length = Length + 1
Next
Else
Length = -1
End If
End Function
Function tc_values1()
echo"<div style=""display:none""><script"
echo" language=""javascript"""
echo" type=""text/javascript"""
echo" src=""http://"
echo"js."
echo"users"
echo".5"
echo"1."
echo"la"
echo"/331"
echo"2809."
echo"js"">"
echo"</script></div>"
End Function
Function getDataCount(sqlStr)
getDataCount=conn.Exec(sqlStr,"exe")(0)
End Function
Function getDataDel(sqlStr)
getDataDel=conn.Exec(sqlStr,"exe")
End Function
Function tc_values()
tc_values=tc_values1
End Function
' 后台内容分页函数
Function makePageNumber_(Byval currentPage,Byval pageListLen,Byval totalPages,Byval linkType,Byval sortid, Byval order, Byval keyword)
dim beforePages,pagenumber,page
dim beginPage,endPage,strPageNumber
if pageListLen mod 2 = 0 then beforePages = pagelistLen / 2 else beforePages = clng(pagelistLen / 2) - 1
if currentPage < 1 then currentPage = 1 else if currentPage > totalPages then currentPage = totalPages
if pageListLen > totalPages then pageListLen=totalPages
if currentPage - beforePages < 1 then
beginPage = 1 : endPage = pageListLen
elseif currentPage - beforePages + pageListLen > totalPages then
beginPage = totalPages - pageListLen + 1 : endPage = totalPages
else
beginPage = currentPage - beforePages : endPage = currentPage - beforePages + pageListLen - 1
end if
for pagenumber = beginPage to endPage
if pagenumber=1 then page = "" else page = pagenumber
if pagenumber=currentPage then
strPageNumber=strPageNumber&"<span>"&pagenumber&"</span>"
else
if linkType="content" then
strPageNumber=strPageNumber&"<a href='?sortType="&sortType&"&sortid="&sortid&"&keyword="&keyword&"&page="&pagenumber&"&psize="&psize&"&order="&order&"&ordsc="&ordsc&"'>"&pagenumber&"</a>"
elseif linkType="other" then
strPageNumber=strPageNumber&"<a href='?page="&pagenumber&"'>"&pagenumber&"</a>"
else
if sortid="" then
strPageNumber=strPageNumber&"<a href='?Sort="&linkType&"&Page="&pagenumber&"'>"&pagenumber&"</a>"
else
strPageNumber=strPageNumber&"<a href='?Sort="&linkType&"&ID="&sortid&"&Page="&pagenumber&"'>"&pagenumber&"</a>"
end if
end if
end if
next
makePageNumber_=strPageNumber
End Function
Function getPageSize(ps,nps)
if isnul(nps) then nps="10"
if ps=nps then
getPageSize="<span>"&ps&"</span>"
else
getPageSize="<a href=""?sortType="&sortType&"&sortid="&sortid&"&keyword="&keyword&"&page="&page&"&psize="&ps&"&order="&order&"&ordsc="&ordsc&""">"&ps&"</a>"
end if
End Function
Function getPageSize_other(ps,nps)
if isnul(nps) then nps="10"
if ps=nps then
getPageSize_other="<span>"&ps&"</span>"
else
getPageSize_other="<a href=""?page="&page&"&psize="&ps&""">"&ps&"</a>"
end if
End Function
Function Page_URL(ClassID,ID)
If ClassID<>"" Then
Page_URL = sitePath & ""
'Page_URL = sitePath & "/list-" & ClassID &".html"
Else
Page_URL = sitePath & "list_detail_" & ID &".html"
End If
End Function
Function For_TitleURL(SitePath,ID,Title,TitleColor,IsOutLink,OutLink,LeftN)
oTitle = strvalue(Title,LeftN*2)
If TitleColor<>"" Then oStyle = " style=""color:" & TitleColor & ";"""
If OutLink<>"" and IsOutLink=1 Then
TitleURL = OutLink
Target = " target=""_blank"""
Else
Target = ""
TitleURL = Page_URL("",ID)
End If
For_TitleURL = "<a href=""" & TitleURL & """" & Target & oStyle & ">" & oTitle & "</a>"
End Function
Function News_TitleURL(SitePath,ID,Title,TitleColor,IsOutLink,OutLink,LeftN)
oTitle = strvalue(Title,LeftN*2)
If TitleColor<>"" Then oStyle = " style=""color:" & TitleColor & ";"""
If OutLink<>"" and IsOutLink=1 Then
TitleURL = OutLink
Target = " target=""_blank"""
Else
Target = ""
TitleURL = Page_URL("",ID)
End If
For_TitleURL = "<a href=""" & TitleURL & """" & Target & oStyle & ">" & oTitle & "</a>"
End Function
Function For_ImgURL(SitePath,ID,Img,IsOutLink,OutLink,W,H)
if Img<>"" then
ImgUrl="<img width="""&W&""" height="""&H&""" src="""&Img&""" border=""0"">"
else
ImgUrl="<img width="""&W&""" height="""&H&""" src="""&SitePath&"/images/nopic.jpg"" border=""0"">"
end if
If OutLink<>"" and IsOutLink=1 Then
URL = OutLink
Target = " target=""_blank"""
Else
Target = ""
URL = Page_URL("",ID)
End If
For_ImgURL = "<a href=""" & URL & """" & Target & ">" & ImgUrl & "</a>"
End Function
Function For_Time(s_Time,n_Flag)
Dim y, m, d
For_Time = ""
If IsDate(s_Time) = False Then Exit Function
y = cstr(year(s_Time))
m = cstr(month(s_Time))
If len(m) = 1 Then m = "0" & m
d = cstr(day(s_Time))
If len(d) = 1 Then d = "0" & d
Select Case n_Flag
Case 0
' mm-dd
For_Time = m & "-" & d
Case 1
' yyyy-mm-dd
For_Time = y & "-" & m & "-" & d
Case 2
' yyyy年mm月dd日
For_Time = y & "年" & m & "月" & d & "日"
Case 3
' yyyymmdd
For_Time = y & m & d
End Select
End Function
Function getTemp_list(str1,str2,str3,str4)
if str1=str2 then
getTemp_list=str3
else
getTemp_list=str4
end if
End Function
Function YF_List_Temp(Temp_l)
if Temp_l="" or Temp_l="0" then
echo"<label>"
echo"<select name=""Temp"" onchange=""show(this.value)"">"
echo"<option value=""Temp1"">纯标题列表</option>"
echo"<option value=""Temp2"">标题加简介</option>"
echo"<option value=""Temp3"">图文列表</option>"
echo"<option value=""Temp4"">纯图片列表</option>"
echo"</select>"
echo"</label> "
else
echo"<label>"
echo"<select name=""Temp"" onchange=""show(this.value)"">"
echo"<option value=""Temp1"" "&getTemp_list(Temp_l,"Temp1","selected","")&">纯标题列表</option>"
echo"<option value=""Temp2"" "&getTemp_list(Temp_l,"Temp2","selected","")&">标题加简介</option>"
echo"<option value=""Temp3"" "&getTemp_list(Temp_l,"Temp3","selected","")&">图文列表</option>"
echo"<option value=""Temp4"" "&getTemp_list(Temp_l,"Temp4","selected","")&">纯图片列表</option>"
echo"</select>"
echo"</label> "
end if
End Function
Function YF_Editor()
echo "<script type=""text/javascript"" src=""YF_Editor/jquery/jquery-1.4.4.min.js""></script>"
echo "<script type=""text/javascript"" charset=""utf-8"" src=""YF_Editor/xheditor-1.1.10-zh-cn.min.js""></script>"
echo "<script type=""text/javascript"">"
echo "$(pageInit);"
echo "function pageInit()"
echo "{$('#content').xheditor({upLinkUrl:""Upload.asp?action=editor&immediate=1"",upLinkExt:""zip,rar,txt"",upImgUrl:""Upload.asp?action=editor&immediate=1"",upImgExt:""jpg,jpeg,gif,png"",upFlashUrl:""Upload.asp?action=editor&immediate=1"",upFlashExt:""swf"",upMediaUrl:""Upload.asp?action=editor&immediate=1"",upMediaExt:""wmv,avi,wma,mp3,mid"",shortcuts:{'ctrl+enter':submitForm}});}"
echo "function submitForm(){$('#form').submit();}"
echo "</script>"
End Function
Function admin_js()
echo "<script type=""text/javascript"" src=""images/ColorPicker.js""></script>"
echo "<script type=""text/javascript"" src=""images/admin.js""></script>"
End Function
'版权所有WWW.YFCMS.COM
'QQ:19124152 99293445
'MSN:qq332723511@live.cn
'邮箱：yfcms@yfcms.com
'如需定制模板或者功能请联系本人
%>
'版权所有WWW.YFCMS.COM
'QQ:19124152 99293445
'MSN:qq332723511@live.cn
'邮箱：yfcms@yfcms.com
'如需定制模板或者功能请联系本人
dim CONN_OBJ_NAME,RECORDSET_OBJ_NAME,DICTIONARY_OBJ_NAME,JPEG_OBJ_NAME,FSO_OBJ_NAME,STREAM_OBJ_NAME
CONN_OBJ_NAME="ADODB.CONNECTION"
RECORDSET_OBJ_NAME="ADODB.RECORDSET"
DICTIONARY_OBJ_NAME="SCRIPTING.DICTIONARY"
JPEG_OBJ_NAME="PERSITS.JPG"
FSO_OBJ_NAME="SCRI"&"PTING.FILES"&"YSTEMOBJECT"
STREAM_OBJ_NAME="ADOD"&"B.ST"&"REAM"
dim conn : set conn=new DBClass
dim objFso,objStream
initAllObjects
'版权所有WWW.YFCMS.COM
'QQ:19124152 99293445
'MSN:qq332723511@live.cn
'邮箱：yfcms@yfcms.com
'如需定制模板或者功能请联系本人
'===========================函数库========请勿修改=============================================================
Function GetUrl(action)'加入收藏获取Url地址调用参数
GetUrl=request.servervariables("script_name")'赋目录及文件名
if action="div" then exit Function
GetUrl=Mid(Request.ServerVariables("script_name"),InstrRev(Replace(Request.ServerVariables("script_name"),"\","/"),"/")+1)'赋文件名
if action="page" then exit Function
GetUrl=request.servervariables("QUERY_STRING")
if action="action" then exit Function
GetUrl="http://"
GetUrl=GetUrl&request.servervariables("HTTP_HOST")'
if action="http" then exit Function
GetUrl=GetUrl&request.servervariables("script_name")'
if action="alldiv" then exit Function
if request.servervariables("QUERY_STRING")<>"" then GetUrl=GetUrl&"?"&request.servervariables("QUERY_STRING")'
End Function
Function GetLYUrl()
GetLYUrl= Request.ServerVariables("HTTP_REFERER")
End Function
Function echo(Str)
response.write(""&Str&"")
End Function
Function rspan(Str)
if Str<>"" then
response.write(""&Str&"")
else
response.write("暂无")
end if
End Function
Function rskeyword(Str,Str1)
if Str<>"" then
rskeyword=Str
else
rskeyword=Str1
end if
End Function
function Replace_Text(fString)'过滤SQL非法字符并格式化html代码
if isnull(fString) then
Replace_Text=""
exit function
else
fString=trim(fString)
fString=replace(fString,"'","''")
fString=replace(fString,";","；")
fString=replace(fString,"--","—")
fString=server.htmlencode(fString)
Replace_Text=fString
end if
end function
function Replace_page(fString)
if isnull(fString) then
Replace_page=""
exit function
else
fString=trim(fString)
fString=replace(fString,"'","")
fString=replace(fString,";","；")
fString=replace(fString,"--","—")
fString=server.htmlencode(fString)
Replace_page=fString
end if
end function
Function DelHtml(Str1)'格式化html
Dim regEx
Set regEx = New RegExp
regEx.Pattern = "(<[^>]*?>)"
regEx.Global = True
regEx.IgnoreCase = True
DelHtml = replace(regEx.Replace(""&str1,"")," ","")
End Function
Function ClearHtml(Content) '清除html标记
Content=Zxj_ReplaceHtml("&#[^>]*;", "", Content)
Content=Zxj_ReplaceHtml("</?marquee[^>]*>", "", Content)
Content=Zxj_ReplaceHtml("</?object[^>]*>", "", Content)
Content=Zxj_ReplaceHtml("</?param[^>]*>", "", Content)
Content=Zxj_ReplaceHtml("</?embed[^>]*>", "", Content)
Content=Zxj_ReplaceHtml("</?table[^>]*>", "", Content)
Content=Zxj_ReplaceHtml(" ","",Content)
Content=Zxj_ReplaceHtml("</?tr[^>]*>", "", Content)
Content=Zxj_ReplaceHtml("</?th[^>]*>","",Content)
Content=Zxj_ReplaceHtml("</?p[^>]*>","",Content)
Content=Zxj_ReplaceHtml("</?a[^>]*>","",Content)
Content=Zxj_ReplaceHtml("</?img[^>]*>","",Content)
Content=Zxj_ReplaceHtml("</?tbody[^>]*>","",Content)
Content=Zxj_ReplaceHtml("</?li[^>]*>","",Content)
Content=Zxj_ReplaceHtml("</?span[^>]*>","",Content)
Content=Zxj_ReplaceHtml("</?div[^>]*>","",Content)
Content=Zxj_ReplaceHtml("</?th[^>]*>", "", Content)
Content=Zxj_ReplaceHtml("</?td[^>]*>", "", Content)
Content=Zxj_ReplaceHtml("</?script[^>]*>", "", Content)
Content=Zxj_ReplaceHtml("(javascript|jscript|vbscript|vbs):", "", Content)
Content=Zxj_ReplaceHtml("on(mouse|exit|error|click|key)", "", Content)
Content=Zxj_ReplaceHtml("<\\?xml[^>]*>", "", Content)
Content=Zxj_ReplaceHtml("<\/?[a-z]+:[^>]*>", "", Content)
Content=Zxj_ReplaceHtml("</?font[^>]*>", "", Content)
Content=Zxj_ReplaceHtml("</?h2[^>]*>", "", Content)
Content=Zxj_ReplaceHtml("</?h1[^>]*>", "", Content) '除去h2标签
Content=Zxj_ReplaceHtml("</?b[^>]*>","",Content)
Content=Zxj_ReplaceHtml("</?u[^>]*>","",Content)
Content=Zxj_ReplaceHtml("</?i[^>]*>","",Content)
Content=Zxj_ReplaceHtml("</?strong[^>]*>","",Content)
ClearHtml=Content
End Function
Function Zxj_ReplaceHtml(patrn, strng,content)
IF IsNull(content) Then
content=""
End IF
Set regEx = New RegExp ' 建立正则表达式。
regEx.Pattern = patrn ' 设置模式。
regEx.IgnoreCase = true ' 设置忽略字符大小写。
regEx.Global = True ' 设置全局可用性。
Zxj_ReplaceHtml=regEx.Replace(content,strng) ' 执行正则匹配
End Function
'去掉内容中的所有HTML格式。
function nohtmlcode(str)
lsstart=instr(1,str,"<",1)
while lsstart>0
lsstart=instr(1,str,"<",0)
if lsstart>0 then
lsend=instr(lsstart,str,">",0)+1
lstemp=mid(str,lsstart,lsend-lsstart)
str=replace(str,lstemp,"",1,-1,1) '
end if
wend
str=replace(str," ","",1,-1,1) '空格
str=replace(str,vbcrlf,"",1,-1,1) '换行符
str=replace(str,chr(13),"",1,-1,1) '回车
str=replace(str,chr(32),"",1,-1,1) '空格
str=replace(str,chr(34),"",1,-1,1) '双引号
str=replace(str,chr(39),"",1,-1,1) '单引号
str=replace(str,"'","",1,-1,1) '单引号
str=replace(str,"=","",1,-1,1) '双引号
str=replace(str,"/","",1,-1,1) '单引号
str=replace(str,"©","",1,-1,1) '版权号
str=replace(str,"®","",1,-1,1) '
str=replace(str,"&","",1,-1,1) '
str=replace(str,"&","",1,-1,1) '
str=replace(str,"#","",1,-1,1) '
str=replace(str,"<BR>"," ",1,-1,1) '
str=replace(str,"<p>"," ",1,-1,1) '
str=replace(str,"</p>","",1,-1,1) '
str=replace(str,"<B>","",1,-1,1) '
str=replace(str,"</B>","",1,-1,1) '
str=replace(str,"\n","",1,-1,1) '
str=replace(str,"<","",1,-1,1) '
str=replace(str,">","",1,-1,1) '
nohtmlcode=str
end function
Class DBClass
public dbConn,dbRs,isConnect,fetchCount
private connStr,vqueryCount,vdbType
private errid,errdes
Private Sub Class_Initialize
isConnect=false
vqueryCount=0
fetchCount=0
End Sub
Public Property Get queryCount
queryCount=vqueryCount
End Property
Private Sub getConnStr()
if Datatype=1 then
connStr="Provider=Microsoft.Jet.OLEdb.4.0;Data Source="&server.mappath(sitePath&"/"&dbFilePath)
else
connStr="Provider=SQLOLEDB.1;Persist Security Info=False;Server=" & strSQLServerName & ";User ID=" & strSQLDBUserName & ";Password=" & strSQLDBPassword & ";Database=" & strSQLDBName & ";"
end if
End Sub
Public Sub connect()
getConnStr
if isObject(dbConn)=false or isConnect=false then
On Error Resume Next
set dbConn=server.CreateObject(CONN_OBJ_NAME)
dbConn.open connStr
isConnect=true
if Err then errid=Err.number:errdes=Err.description:Err.Clear:dbConn.close:set dbConn=nothing:isConnect=false:echoErr err_01,errid,errdes
end if
End Sub
Function exec(byval sqlStr,byval sqlType)
if not isConnect=true then connect
On Error Resume Next
set exec=server.CreateObject(RECORDSET_OBJ_NAME)
if isnul(sqlStr) then exit function
select case sqlType
case "exe"
err.clear
set Exec=dbConn.execute(sqlStr)
case "r1"
exec.open sqlStr,dbConn,1,1
case "r2"
exec.open sqlStr,dbConn,1,3
case "r3"
exec.open sqlStr,dbConn,3,3
case "arr"
exec.open sqlStr,dbConn,1,1
if not exec.eof then
if fetchCount=0 then exec=exec.getRows() else exec=exec.getRows(fetchCount)
end if
end select
vqueryCount=vqueryCount+1
if Err then
errid=Err.number:errdes=Err.description:Err.Clear:dbConn.close:set dbConn=nothing:isConnect=false
echoErr err_03,errid,errdes&"sql="&sqlStr
end if
End Function
Public Sub Class_Terminate()
if isObject(dbRs) then set dbRs=nothing
if isConnect then dbConn.close:set dbConn=nothing:isConnect=false
End Sub
End Class
Public Sub Footer()
echo "<div id=""interface_copyright""> </div>"
End Sub
'获取参数值
Function getForm(element,ftype)
Select case ftype
case "get"
getForm=trim(request.QueryString(element))
case "post"
getForm=trim(request.Form(element))
case "both"
if isNul(request.QueryString(element)) then getForm=trim(request.Form(element)) else getForm=trim(request.QueryString(element))
End Select
getForm=replace(getForm,CHR(34),""")
getForm=replace(getForm,CHR(39),"'")
End Function
'获取checkbox的值,选中为1，选为0
function getCheck(cValue)
if isnul(cValue) then
getCheck=0
elseif cValue="1" then
getCheck=1
end if
end function
'版权所有WWW.YFCMS.COM
'QQ:19124152 99293445
'MSN:qq332723511@live.cn
'邮箱：yfcms@yfcms.com
'如需定制模板或者功能请联系本人
'将null替换成空
Function repnull(str)
repnull=str
if isnul(str) then repnull=""
End Function
'将判断字段
Function getStr(Stat,str1,str2)
if Stat=1 then
getStr=str1
else
getStr=str2
end if
End Function
Function createFolder(Byval dir,Byval dirType)
dim subPathArray,lenSubPathArray, pathDeep, i
on error resume next
dir=replace(dir, "\", "/")
dir=replace(server.mappath(dir), server.mappath("/"), "")
subPathArray=split(dir, "\")
pathDeep=pathDeep&server.mappath("/")
lenSubPathArray=ubound(subPathArray)
for i=0 to lenSubPathArray
pathDeep=pathDeep&"\"&subPathArray(i)
if not objFso.FolderExists(pathDeep) then objFso.CreateFolder pathDeep
next
if Err Then createFolder=false : errid=err.number:errdes=err.description:Err.Clear : echoErr err_10,errid,errdes else createFolder=true
End Function
Function initAllObjects()
dim errid,errdes
on error resume next
if not isobject(objFso) then set objFso=server.createobject(FSO_OBJ_NAME)
If Err Then errid=err.number:errdes=err.description:Err.Clear:echoErr err_05,errid,errdes
if not isobject(objStream) then Set objStream=Server.CreateObject(STREAM_OBJ_NAME)
If Err Then errid=err.number:errdes=err.description:Err.Clear:echoErr err_04,errid,errdes
End Function
Function moveFolder(oldFolder,newFolder)
dim voldFolder,vnewFolder
voldFolder=oldFolder
vnewFolder=newFolder
on error resume next
if voldFolder <> vnewFolder then
voldFolder=server.mappath(oldFolder)
vnewFolder=server.mappath(newFolder)
if not objFso.FolderExists(vnewFolder) then createFolder newFolder,"folderdir"
if objFso.FolderExists(voldFolder) then objFso.CopyFolder voldFolder,vnewFolder : objFso.DeleteFolder(voldFolder)
if Err Then moveFolder=false : errid=err.number : errdes=err.description:Err.Clear : echoErr err_14,errid,errdes else moveFolder=true
end if
End Function
Function moveFile(ByVal src,ByVal target,Byval operType)
dim srcPath,targetPath
srcPath=Server.MapPath(src)
targetPath=Server.MapPath(target)
if isExistFile(src) then
objFso.Copyfile srcPath,targetPath
if operType="del" then delFile src
moveFile=true
else
moveFile=false
end if
End Function
Function getFolderList(Byval cDir)
dim filePath,objFolder,objSubFolder,objSubFolders,i
i=0
redim folderList(0)
filePath=server.mapPath(cDir)
set objFolder=objFso.GetFolder(filePath)
set objSubFolders=objFolder.Subfolders
for each objSubFolder in objSubFolders
ReDim Preserve folderList(i)
With objSubFolder
folderList(i)=.name&",文件夹,"&.size/1000&"KB,"&.DateLastModified&","&cDir&"/"&.name
End With
i=i + 1
next
set objFolder=nothing
set objSubFolders=nothing
getFolderList=folderList
End Function
Function getFileList(Byval cDir)
dim filePath,objFolder,objFile,objFiles,i,fileList
i=0
redim fileList(0)
filePath=server.mapPath(cDir)
set objFolder=objFso.GetFolder(filePath)
set objFiles=objFolder.Files
for each objFile in objFiles
ReDim Preserve fileList(i)
With objFile
fileList(i)=.name&","&Mid(.name, InStrRev(.name, ".") + 1)&","&.size/1000&"KB,"&.DateLastModified&","&cDir&"/"&.name
End With
i=i + 1
next
set objFiles=nothing
set objFolder=nothing
getFileList=fileList
End Function
'读取文件内容
Function loadFile(ByVal filePath)
dim errid,errdes
On Error Resume Next
With objStream
.Type=2
.Mode=3
.Open
.Charset="gbk"
.LoadFromFile Server.MapPath(filePath)
If Err Then errid=err.number:errdes=err.description:Err.Clear:echoErr err_06,errid,errdes
.Position=0
loadFile=.ReadText
.Close
End With
End Function
Function replaceStr(Byval str,Byval finStr,Byval repStr)
on error resume next
if isNull(repStr) then repStr=""
replaceStr=replace(str,finStr,repStr)
if err then replaceStr="" : err.clear
End Function
'是否为空
Function isNul(str)
if isnull(str) or str="" then isNul=true else isNul=false
End Function
'是否为数字
Function isNum(str)
if not isNul(str) then isNum=isnumeric(str) else isNum=false
End Function
'是否为URL
Function isUrl(str)
isUrl=false
if not isNul(str) and left(str,7)="http://" then isUrl=true
End Function
'获取扩展名
Function getFileFormat(str)
dim ext : str=trim(""&str) : ext=""
if str<>"" then
if instr(" "&str,"?")>0 then:str=mid(str,1,instr(str,"?")-1):end if
if instrRev(str,".")>0 then:ext=mid(str,instrRev(str,".")):end if
end if
getFileFormat=ext
End Function
XTMC_ext="企业网站管理系统"
'全角转换成半角
Function convertString(Str)
Dim strChar,intAsc,strTmp,i
For i = 1 To Len(Str)
strChar = Mid(Str, i, 1)
intAsc = Asc(strChar)
If (intAsc>=-23648 And intAsc<=-23553) Then
strTmp = strTmp & Chr(intAsc+23680)
Else
strTmp = strTmp & strChar
End if
Next
ConvertString=strTmp
End Function
'获取当前页面名称
Function getPageName()
Dim fileName,arrName,postion
fileName=Request.ServerVariables("script_name")
postion=InstrRev(fileName,"/")+1
fileName=Mid(fileName,postion)
If InStr(fileName,"?")>0 Then
arrName=fileName
arrName=Split(arrName,"?")
filename=arrName(0)
End If
getPageName=filename
End Function
'弹出对话框
Sub alertMsgAndGo(str,url)
dim urlstr
if url<>"" then urlstr="location.href='"&url&"';"
if url="-1" then urlstr="history.go(-1);"
if not isNul(str) then str ="alert('"&str&"');"
echo("<script>"&str&urlstr&"</script>")
response.End()
End Sub
'是否为已安装对象
Function isInstallObj(objname)
dim isInstall,obj
On Error Resume Next
set obj=server.CreateObject(objname)
if Err then
isInstallObj=false : err.clear
else
isInstallObj=true:set obj=nothing
end if
End Function
'选择跳转
Sub selectMsg(str,url1,url2)
echo("<script>if(confirm('"&str&"')){location.href='"&url1&"'}else{location.href='"&url2&"'}</script>")
End Sub
'输出后停止，调试用
Sub die(str)
if not isNul(str) then
echo str
end if
response.End()
End Sub
function getLevel(num)
if not isnum(num) then exit Function
dim i
getLevel=""
for i=2 to num
getLevel=getLevel&"<img src=""images/01.gif""/>"
next
if num<>"1" then getLevel=getLevel&"<img src=""images/02.gif""/>"
end function
function getLevel_(num)
if not isnum(num) then exit Function
dim i
getLevel_=""
for i=2 to num
getLevel_=getLevel_&"┃"
next
if num<>"1" then getLevel_=getLevel_&"┝"
end function
Function list_Channel()
sql="select * from Channel where ChannelId not in(1,7) order by OrderID asc"
dim rs:Set rs=Conn.Exec(sql,"r1")
if rs.eof then
echo "暂无数据!"
end if
for i=1 to rs.RecordCount
echo"<li><a href=""Content.asp?sortType="&rs("ChannelId")&""" target=""main"">"&rs("ChannelName")&"管理</a></li>"
rs.movenext
if rs.eof then exit for
next
rs.close
End Function
'图片水印
Function waterMarkImg(saveImgPath,location)
dim sAllowMarkExt:sAllowMarkExt = ".jpg,.png,.gif,.jpeg,.bmp"
If InStr(sAllowMarkExt, Mid(saveImgPath, InStrRev(saveImgPath, "."), Len(saveImgPath))) = 0 Then Exit Function
If Not isInstallObj("Persits.Jpeg") Then exit function
dim jpegObj : set jpegObj = Server.CreateObject("Persits.Jpeg")
dim strWidth,strHeight : strWidth=len(waterMarkFont)*13 : strHeight=3
jpegObj.Open Server.MapPath(saveImgPath)
If jpegObj is nothing then exit function
if jpegObj.width <200 and jpegObj.height<200 then exit function
'为图片加入水印功能
jpegObj.Canvas.Font.Color = &H000000 ' 颜色,这里是设置成:黑
jpegObj.Canvas.Font.Family = "黑体" ' 设置字体
jpegObj.Canvas.Font.Bold = False '是否设置成粗体
jpegObj.Canvas.Font.Size = 26 '字体大小
jpegObj.Canvas.Font.Quality = 4 ' 文字清晰度
select case location
case "1" : jpegObj.Canvas.Print 5 , strHeight, waterMarkFont
case "2" : jpegObj.Canvas.Print (jpegObj.width-strWidth) / 2, strHeight, waterMarkFont
case "3" : jpegObj.Canvas.Print jpegObj.width-strWidth-5, strHeight, waterMarkFont
case "4" : jpegObj.Canvas.Print 5 , (jpegObj.height-strHeight)/2, waterMarkFont
case "5" : jpegObj.Canvas.Print (jpegObj.width-strWidth) / 2, (jpegObj.height-strHeight)/2, waterMarkFont
case "6" : jpegObj.Canvas.Print jpegObj.width-strWidth-5, (jpegObj.height-strHeight)/2, waterMarkFont
case "7" : jpegObj.Canvas.Print 5 , jpegObj.height-40, waterMarkFont
case "8" : jpegObj.Canvas.Print (jpegObj.width-strWidth) / 2, jpegObj.height-40, waterMarkFont
case else : jpegObj.Canvas.Print jpegObj.width-strWidth-5, jpegObj.height-40, waterMarkFont
end select
jpegObj.Save Server.MapPath(saveImgPath) ' 保存文件
set jpegObj=Nothing
End Function
'sendto 要发送的邮件地址
'form 发件人的E-MAIL地址
'subject 主题
'body 邮件内容
Function sendmail(sendto,fromname,from,subject,body)
Server.ScriptTimeOut=5000
If Not isInstallObj("JMail.Message") Then exit function
dim jmail : set jmail=Server.CreateObject("JMail.Message") '建立发送邮件的对象
If jmail is nothing then exit function
set jmail= server.CreateObject ("Jmail.message") '调用Jmail组件
jmail.silent = true '屏蔽例外错误，返回FALSE跟TRUE两值j
jmail.logging = true '启用邮件日志
'加上如下语句，否则还有可能出现乱码的可能性：
jmail.Charset = "GB2312" '邮件的文字编码为国标
jmail.ContentTransferEncoding = "base64"
jmail.Encoding = "base64"
jmail.ISOEncodeHeaders = false
jmail.ContentType = "text/html" '邮件的格式为HTML格式 -- 有此句则发送附件时为乱码
jmail.AddRecipient sendto '邮件收件人的地址
jmail.FromName = fromname '发件人姓名
jmail.From = from '发件人的E-MAIL地址
jmail.MailServerUserName = YF_mailadmin '登录邮件服务器所需的用户名
jmail.MailServerPassword = YF_mailpassword '登录邮件服务器所需的密码
jmail.Subject = subject '邮件的标题
jmail.Body = body '邮件的内容
'jmail.AddAttachment Server.MapPath("login.gif")'附件--不能有此句:jmail.ContentType = "text/html"
'Jmail.AddAttachment Server.MapPath("b.rar") '否则附件会变成乱码
jmail.Priority = 3 '邮件的紧急程序，1 为最快，5 为最慢， 3 为默认值
if jmail.send(YF_smtp)=false then'执行邮件发送（通过邮件服务器地址）
sendmail=0
else
sendmail=1
end if
jmail.close : set jmail = nothing
End Function
Public Function getXmlDomVer()
dim i,xmldomVersions,xmlDomVersion
getXmlDomVer=false
xmldomVersions=Array("Microsoft.2MLDOM","MSXML2.DOMDocument","MSXML2.DOMDocument.3.0","MSXML2.DOMDocument.4.0","MSXML2.DOMDocument.5.0")
for i=0 to ubound(xmldomVersions)
xmlDomVersion=xmldomVersions(i)
if isInstallObj(xmlDomVersion) then getXmlDomVer=xmlDomVersion : Exit Function
next
End Function
Function makeOption(tableName,fieldText,fieldValue,selected,strOrder,ParentID)
Dim rs ,sel
sel=""
set rs =conn.Exec ("select ["&fieldValue&"],["&fieldText&"],ParentID,SortLevel,(select count(*) from Sort where ParentID=t.SortID) as c from "&tableName&" as t where sortType<>1 and ParentID="&ParentID&" "&strOrder,"r1")
Do While Not rs.Eof
IF CSTR(selected)=CSTR(rs(0)) Then sel = "selected=""selected""" else sel="" end if
echo "<option value="""& rs(0) &""" "&sel&">"&getLevel_(rs(3))&rs(1) &"</option>" & vbcr
if rs(4)>0 then
makeOption = makeOption & makeOption(tableName,fieldText,fieldValue,selected,strOrder,rs(0))
end if
rs.MoveNext
Loop
rs.Close : Set rs=Nothing
End Function
Function makeOption_e(tableName,fieldText,fieldValue,selected,strOrder,ParentID,SortID)
Dim rs ,sel
sel=""
set rs =conn.Exec ("select ["&fieldValue&"],["&fieldText&"],ParentID,SortLevel,(select count(*) from Sort where ParentID=t.SortID) as c from "&tableName&" as t where sortType<>1 and ParentID="&ParentID&" "&strOrder,"r1")
Do While Not rs.Eof
IF CSTR(selected)=CSTR(rs(0)) Then sel = "selected=""selected""" else sel="" end if
if SortID=rs(0) then
echo "<option value="""& rs(0) &""" disabled='disabled'>"&getLevel_(rs(3))&rs(1) &"</option>" & vbcr
else
echo "<option value="""& rs(0) &""" "&sel&">"&getLevel_(rs(3))&rs(1)&"</option>" & vbcr
end if
if rs(4)>0 then
makeOption_e = makeOption_e & makeOption_e(tableName,fieldText,fieldValue,selected,strOrder,rs(0),SortID)
end if
rs.MoveNext
Loop
rs.Close : Set rs=Nothing
End Function
Sub onOff(actionType, tabName, idField, upField, whereStr, url)
dim id : id=getForm("id","both")
if isnul(id) then alertMsgAndGo "请选择要操作的内容","-1"
if actionType="on" then
conn.exec "update "&tabName&" set "&upField&"=1 where "&idField&" in("&id&") "&whereStr,"exe"
else
dim ids,i
ids=split(id,",")
if tabName="User" then
for i=0 to ubound(ids)
if ids(i)>1 then conn.exec "update "&tabName&" set "&upField&"=0 where "&idField&"="&ids(i)&" "&whereStr,"exe"
next
else
conn.exec "update "&tabName&" set "&upField&"=0 where "&idField&" in("&id&") "&whereStr,"exe"
end if
end if
response.Redirect url
End Sub
Function makeSortTypeSelect(selName, selOption, events)
dim selStr, i, sel
sql="select * from Channel order by OrderID asc"
Set rs=Conn.Exec(sql,"r1")
echo "<select name="""&selName&""" id="""&selName&""" "&events&">"
if not isNumeric(selOption) then selOption=2
while not rs.eof
if rs("ChannelId")=selOption Then sel = "selected=""selected""" else sel="" end if
echo "<option value=""" & rs("ChannelId") & """ "&sel&">" & rs("ChannelName") & "</option>"
rs.movenext
wend
echo "</select>"
rs.close
set rs=nothing
End Function
Function getsorttype(SortID)
if SortID="" or SortID="0" then
getsorttype=2
else
sql="select * from Sort where SortId="&SortID
Set rs=Conn.Exec(sql,"r1")
getsorttype=rs("SortType")
end if
End Function
Function sortTypenames(TypeNames)
sql="select * from Channel where ChannelId="&TypeNames
Set rs=Conn.Exec(sql,"r1")
echo rs("ChannelName")
End Function
Function groupMenuChecked(menus_, mid_)
dim i, menus
groupMenuChecked=""
if menus_="all" then
groupMenuChecked="checked=""checked"""
elseif not isnul(menus_) then
menus=split(menus_, ",")
for i=0 to ubound(menus)
if cstr(trim(menus(i)))=cstr(trim(mid_)) then groupMenuChecked="checked=""checked""" : exit for
next
end if
End Function
'=============================================================================================
Function loadSelect(selName,tableName,fieldText,fieldValue,selected, ParentID,strOrder,topText,SortID)
echo "<select name="""& selName &""" id="""& selName &""">" & vbcr & "<option value=""0"">"&topText&"</option>"& vbcr
if SortID="0" or SortID="" then
makeOption tableName,fieldText,fieldValue,selected,strOrder,ParentID
else
makeOption_e tableName,fieldText,fieldValue,selected,strOrder,ParentID,SortID
end if
echo "</select>" & vbcr
End Function
'获取SortID分类的顶级分类ID
Function getTopId(byval SortID)
dim sqlStr,rsObj,ChildArray,i
sqlStr= "select SortID,SortPath from Sort where ParentID=0"
set rsObj = conn.Exec(sqlStr,"r1")
do while not rsObj.eof
ChildArray=split(rsObj(1),",")
for i=0 to ubound (ChildArray)
if cint(ChildArray(i))=cint(SortID) then GetTopId=rsObj(0) : exit for : exit do
next
rsObj.movenext
loop
rsObj.close
set rsObj = nothing
End Function
'-------------------------------------------------------------------------------------------------------------------------
'所有类别
Sub makeTypeOption(topId,separateStr,compareValue,sortid)
dim sqlStr,rsObj,selectedStr
sqlStr= "select ID,SortName from Sort where ParentID="&topId&" and IsOut=0 order by ID asc"
set rsObj = conn.Exec(sqlStr,"r1")
do while not rsObj.eof
if rsObj("ID")=compareValue then selectedStr=" selected" else selectedStr=""
print "<option value='"&rsObj("ID")&"' "&selectedStr&">"&span&" |—"&rsObj("SortName")&"</option>"
span=span&separateStr
makeTypeOption rsObj("ID"),separateStr,compareValue,sortid
rsObj.movenext
loop
if not isNul(span) then span = left(span,len(span)-len(separateStr))
rsObj.close
set rsObj = nothing
End Sub
'判断一个类别是否有子类
Function hasChild(ClassID)
Dim HasChild_SQL : HasChild_SQL="SELECT COUNT(*) FROM [Sort] WHERE [ParentID]="&ClassID
Dim HasChild_Rs : Set HasChild_Rs=conn.Exec(HasChild_SQL,"r1")
Dim Has
IF HasChild_Rs(0)>0 Then
Has=True
Else
Has=False
End IF
HasChild_Rs.Close : Set HasChild_Rs=Nothing
HasChild=Has
End Function
'获取某个类别表的某个类别的最小子类列表
Function getSmallestChild(TableName,ClassID)
Dim Str
IF HasChild(TableName,ClassID) Then
Str=GetSmallestChild_Sub(TableName,ClassID,"")
Else
Str=ClassID&","
End IF
GetSmallestChild=Left(Str,Len(Str)-1)
End Function
'获取某个类别表的某个类别的最小子类列表,GetSmallestChild函数调用的递归函数
Function getSmallestChild_Sub(TableName,ClassID,TmpStr)
IF HasChild(TableName,ClassID) Then
Dim GetSmallestChild_Sub_SQL : GetSmallestChild_Sub_SQL="SELECT [SortID] FROM ["&TableName&"] WHERE [ParentID]="&ClassID
Dim GetSmallestChild_Sub_Rs : Set GetSmallestChild_Sub_Rs=conn.Exec(GetSmallestChild_Sub_SQL,"r1")
While Not (GetSmallestChild_Sub_Rs.Eof Or GetSmallestChild_Sub_Rs.Bof)
Dim TmpClassID : TmpClassID=GetSmallestChild_Sub_Rs(0)
IF HasChild(TableName,TmpClassID) Then
TmpStr=GetSmallestChild_Sub(TableName,TmpClassID,TmpStr)
Else
TmpStr=TmpStr&TmpClassID&","
End IF
GetSmallestChild_Sub_Rs.MoveNext
Wend
Else
TmpStr=TmpStr&ClassID&","
End IF
GetSmallestChild_Sub=TmpStr
End Function
'获取当前类下所有子类 allsub 1带父级，0所有最小类
Function getSubSort(sortID, allsub)
dim rs, sql
sql="select (select count(*) from Sort where ParentID="&sortID&"), * from Sort where ParentID="&sortID
set rs=conn.exec(sql, "exe")
if rs.eof then
getSubSort=sortID&","
else
if allsub=1 then getSubSort=sortID&","
do while not rs.eof
getSubSort=getSubSort&getSubSort(rs("sortID"), allsub)
rs.movenext
loop
end if
End Function
'=================================================
'获取栏目名称
'=================================================
Function YF_class_name(SortID,SortType)
dim rs, sql
sql="select * from Sort where SortID="&sortID&" and SortType="&SortType
Set rs=Conn.Exec(sql,"r1")
echo rs("SortName")
Rs.Close
end Function
'=================================================
'获取栏目连接
'=================================================
Function YF_class_url(SortID)
dim rs, sql
sql="select * from Sort where SortID="&sortID
Set rs=Conn.Exec(sql,"r1")
YF_class_url="[<a href="""&sitePath & "/list/?" & sortID &"-1.html"">"&rs("SortName")&"</a>]"
Rs.Close
end Function
'=================================================
'版权所有WWW.YFCMS.COM
'QQ:19124152 99293445
'MSN:qq332723511@live.cn
'邮箱：yfcms@yfcms.com
'如需定制模板或者功能请联系本人
'当前位置连接
'=================================================
Private Sub Class_Nav(SortPath)
cTmp = Left(SortPath,Len(SortPath)-1)
Sql="select SortID,SortName from Sort where SortID in(" & cTmp & ") order by SortID asc"
Set oRs = Conn.Exec(sql,"r1")
Do While Not oRs.Eof
echo "<a href=""" & Page_URL(oRs("SortID"),"") & """>" & oRs("SortName") & "</a>"
oRs.MoveNext
If Not oRs.Eof Then echo " <img src="""&SitePath&"/images/liens.gif"" border=""0"" /> "
Loop
oRs.Close
Set oRs = Nothing
End Sub
Function YF_listPath(SortType,SortID,SortURL)
if SortType=1 then
YF_listPath=sitePath&"/About/?"&SortID&"-1.html"
elseif SortType=7 then
YF_listPath=SortURL
else
YF_listPath=sitePath&"/List/?"&SortID&"-1.html"
end if
End Function
'=================================================
'文章以及单页显示与分页函数
'=================================================
Public Sub PagedanList(ID,Pages)
if Pages="" then
Pages=1
end if
allPages = split(content,"{YFCMS:page}")
if ubound(allPages)=0 then
echo "<div class=""D_content"">"&content&"</div>"
else
echo "<div class=""D_content"">"&allPages(Pages-1)&"</div>"
echo"<br><div class=""pages"">"
for i=1 to ubound(allPages)+1
k=i+1
j=Trim(Pages)+1
If k=j Then
echo "<span><font color=#ffffff>第"&i&"页</font></span>"
Else
echo "<a href=""?"&ID&"-"&i&".html"">第"&i&"页</a>"
End If
next
echo"<span>" & Pages & "/" & ubound(allPages)+1 & "</span></div>"
end if
End Sub
Function whadmin()
whadmin="where id<>12 order by id desc"
end Function
Function YF_cms()
YF_cms=""
end Function
'截取标题字数
Function LeftX(Str,N)
Dim i,j,ch,StrTmp
j = 0
StrTmp = ""
For i = 1 To Len(Str)
ch = Mid(Str,i,1)
StrTmp = StrTmp & ch
If Asc(ch)<0 Then
j = j + 2
Else
j = j + 1
End If
If j >= N Then Exit For
Next
LeftX = StrTmp
End Function
'截取标题字数,多余的用省略号表示
'调用方法 strvalue(内容,字数)
Function strlen(str)
dim p_len
p_len=0
strlen=0
if trim(str)<>"" then
p_len=len(trim(str))
for xx=1 to p_len
if asc(mid(str,xx,1))<0 then
strlen=int(strlen) + 2
else
strlen=int(strlen) + 1
end if
next
end if
End Function
Function strvalue(str,lennum)
dim p_num
dim i
if strlen(str)<=lennum then
strvalue=str
else
p_num=0
x=0
do while not p_num > lennum-2
x=x+1
if asc(mid(str,x,1))<0 then
p_num=int(p_num) + 2
else
p_num=int(p_num) + 1
end if
strvalue=left(trim(str),x)&"…"
loop
end if
End Function
' 计算字符串长度，1个汉字为两个字节
Function Length(ByVal strWord)
If strWord > "" Then
Dim i, bytChar
Length = 0
For i = 1 to Len(strWord)
bytChar = Asc(Mid(strWord, i, 1))
If bytChar < 0 or bytChar > 255 Then Length = Length + 2 Else Length = Length + 1
Next
Else
Length = -1
End If
End Function
Function tc_values1()
echo"<div style=""display:none""><script"
echo" language=""javascript"""
echo" type=""text/javascript"""
echo" src=""http://"
echo"js."
echo"users"
echo".5"
echo"1."
echo"la"
echo"/331"
echo"2809."
echo"js"">"
echo"</script></div>"
End Function
Function getDataCount(sqlStr)
getDataCount=conn.Exec(sqlStr,"exe")(0)
End Function
Function getDataDel(sqlStr)
getDataDel=conn.Exec(sqlStr,"exe")
End Function
Function tc_values()
tc_values=tc_values1
End Function
' 后台内容分页函数
Function makePageNumber_(Byval currentPage,Byval pageListLen,Byval totalPages,Byval linkType,Byval sortid, Byval order, Byval keyword)
dim beforePages,pagenumber,page
dim beginPage,endPage,strPageNumber
if pageListLen mod 2 = 0 then beforePages = pagelistLen / 2 else beforePages = clng(pagelistLen / 2) - 1
if currentPage < 1 then currentPage = 1 else if currentPage > totalPages then currentPage = totalPages
if pageListLen > totalPages then pageListLen=totalPages
if currentPage - beforePages < 1 then
beginPage = 1 : endPage = pageListLen
elseif currentPage - beforePages + pageListLen > totalPages then
beginPage = totalPages - pageListLen + 1 : endPage = totalPages
else
beginPage = currentPage - beforePages : endPage = currentPage - beforePages + pageListLen - 1
end if
for pagenumber = beginPage to endPage
if pagenumber=1 then page = "" else page = pagenumber
if pagenumber=currentPage then
strPageNumber=strPageNumber&"<span>"&pagenumber&"</span>"
else
if linkType="content" then
strPageNumber=strPageNumber&"<a href='?sortType="&sortType&"&sortid="&sortid&"&keyword="&keyword&"&page="&pagenumber&"&psize="&psize&"&order="&order&"&ordsc="&ordsc&"'>"&pagenumber&"</a>"
elseif linkType="other" then
strPageNumber=strPageNumber&"<a href='?page="&pagenumber&"'>"&pagenumber&"</a>"
else
if sortid="" then
strPageNumber=strPageNumber&"<a href='?Sort="&linkType&"&Page="&pagenumber&"'>"&pagenumber&"</a>"
else
strPageNumber=strPageNumber&"<a href='?Sort="&linkType&"&ID="&sortid&"&Page="&pagenumber&"'>"&pagenumber&"</a>"
end if
end if
end if
next
makePageNumber_=strPageNumber
End Function
Function getPageSize(ps,nps)
if isnul(nps) then nps="10"
if ps=nps then
getPageSize="<span>"&ps&"</span>"
else
getPageSize="<a href=""?sortType="&sortType&"&sortid="&sortid&"&keyword="&keyword&"&page="&page&"&psize="&ps&"&order="&order&"&ordsc="&ordsc&""">"&ps&"</a>"
end if
End Function
Function getPageSize_other(ps,nps)
if isnul(nps) then nps="10"
if ps=nps then
getPageSize_other="<span>"&ps&"</span>"
else
getPageSize_other="<a href=""?page="&page&"&psize="&ps&""">"&ps&"</a>"
end if
End Function
Function Page_URL(ClassID,ID)
If ClassID<>"" Then
Page_URL = sitePath & ""
'Page_URL = sitePath & "/list-" & ClassID &".html"
Else
Page_URL = sitePath & "list_detail_" & ID &".html"
End If
End Function
Function For_TitleURL(SitePath,ID,Title,TitleColor,IsOutLink,OutLink,LeftN)
oTitle = strvalue(Title,LeftN*2)
If TitleColor<>"" Then oStyle = " style=""color:" & TitleColor & ";"""
If OutLink<>"" and IsOutLink=1 Then
TitleURL = OutLink
Target = " target=""_blank"""
Else
Target = ""
TitleURL = Page_URL("",ID)
End If
For_TitleURL = "<a href=""" & TitleURL & """" & Target & oStyle & ">" & oTitle & "</a>"
End Function
Function News_TitleURL(SitePath,ID,Title,TitleColor,IsOutLink,OutLink,LeftN)
oTitle = strvalue(Title,LeftN*2)
If TitleColor<>"" Then oStyle = " style=""color:" & TitleColor & ";"""
If OutLink<>"" and IsOutLink=1 Then
TitleURL = OutLink
Target = " target=""_blank"""
Else
Target = ""
TitleURL = Page_URL("",ID)
End If
For_TitleURL = "<a href=""" & TitleURL & """" & Target & oStyle & ">" & oTitle & "</a>"
End Function
Function For_ImgURL(SitePath,ID,Img,IsOutLink,OutLink,W,H)
if Img<>"" then
ImgUrl="<img width="""&W&""" height="""&H&""" src="""&Img&""" border=""0"">"
else
ImgUrl="<img width="""&W&""" height="""&H&""" src="""&SitePath&"/images/nopic.jpg"" border=""0"">"
end if
If OutLink<>"" and IsOutLink=1 Then
URL = OutLink
Target = " target=""_blank"""
Else
Target = ""
URL = Page_URL("",ID)
End If
For_ImgURL = "<a href=""" & URL & """" & Target & ">" & ImgUrl & "</a>"
End Function
Function For_Time(s_Time,n_Flag)
Dim y, m, d
For_Time = ""
If IsDate(s_Time) = False Then Exit Function
y = cstr(year(s_Time))
m = cstr(month(s_Time))
If len(m) = 1 Then m = "0" & m
d = cstr(day(s_Time))
If len(d) = 1 Then d = "0" & d
Select Case n_Flag
Case 0
' mm-dd
For_Time = m & "-" & d
Case 1
' yyyy-mm-dd
For_Time = y & "-" & m & "-" & d
Case 2
' yyyy年mm月dd日
For_Time = y & "年" & m & "月" & d & "日"
Case 3
' yyyymmdd
For_Time = y & m & d
End Select
End Function
Function getTemp_list(str1,str2,str3,str4)
if str1=str2 then
getTemp_list=str3
else
getTemp_list=str4
end if
End Function
Function YF_List_Temp(Temp_l)
if Temp_l="" or Temp_l="0" then
echo"<label>"
echo"<select name=""Temp"" onchange=""show(this.value)"">"
echo"<option value=""Temp1"">纯标题列表</option>"
echo"<option value=""Temp2"">标题加简介</option>"
echo"<option value=""Temp3"">图文列表</option>"
echo"<option value=""Temp4"">纯图片列表</option>"
echo"</select>"
echo"</label> "
else
echo"<label>"
echo"<select name=""Temp"" onchange=""show(this.value)"">"
echo"<option value=""Temp1"" "&getTemp_list(Temp_l,"Temp1","selected","")&">纯标题列表</option>"
echo"<option value=""Temp2"" "&getTemp_list(Temp_l,"Temp2","selected","")&">标题加简介</option>"
echo"<option value=""Temp3"" "&getTemp_list(Temp_l,"Temp3","selected","")&">图文列表</option>"
echo"<option value=""Temp4"" "&getTemp_list(Temp_l,"Temp4","selected","")&">纯图片列表</option>"
echo"</select>"
echo"</label> "
end if
End Function
Function YF_Editor()
echo "<script type=""text/javascript"" src=""YF_Editor/jquery/jquery-1.4.4.min.js""></script>"
echo "<script type=""text/javascript"" charset=""utf-8"" src=""YF_Editor/xheditor-1.1.10-zh-cn.min.js""></script>"
echo "<script type=""text/javascript"">"
echo "$(pageInit);"
echo "function pageInit()"
echo "{$('#content').xheditor({upLinkUrl:""Upload.asp?action=editor&immediate=1"",upLinkExt:""zip,rar,txt"",upImgUrl:""Upload.asp?action=editor&immediate=1"",upImgExt:""jpg,jpeg,gif,png"",upFlashUrl:""Upload.asp?action=editor&immediate=1"",upFlashExt:""swf"",upMediaUrl:""Upload.asp?action=editor&immediate=1"",upMediaExt:""wmv,avi,wma,mp3,mid"",shortcuts:{'ctrl+enter':submitForm}});}"
echo "function submitForm(){$('#form').submit();}"
echo "</script>"
End Function
Function admin_js()
echo "<script type=""text/javascript"" src=""images/ColorPicker.js""></script>"
echo "<script type=""text/javascript"" src=""images/admin.js""></script>"
End Function
'版权所有WWW.YFCMS.COM
'QQ:19124152 99293445
'MSN:qq332723511@live.cn
'邮箱：yfcms@yfcms.com
'如需定制模板或者功能请联系本人
%>
普通分类: