欢迎各位兄弟 发布技术文章

这里的技术是共享的

asp 常用函数

<%
'版权所有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,""),"&nbsp;","")
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,"&nbsp;","",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,"&copy;","",1,-1,1)    '版权号
    str=replace(str,"&reg;","",1,-1,1)    '
    str=replace(str,"&amp;","",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),"&quot;")
    getForm=replace(getForm,CHR(39),"&apos;")
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&"&nbsp;|—"&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 "&nbsp;<img src="""&SitePath&"/images/liens.gif"" border=""0"" />&nbsp;"
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
'如需定制模板或者功能请联系本人
%>
唯物品评历史

关注"唯物品评历史",跟着泪痕春雨先生,读懂历史,看彻人生

打开隐藏二维码