⭐ 欢迎来到虫虫下载站！ | 📦 资源下载 📁 资源专辑 ℹ️ 关于我们
⭐ 虫虫下载站
📤 上传资源

📄 cls.common.asp

📁 网人分类信息5.0商业版。非常优秀的分类信息系统。比较少见。
💻 ASP
📖 第 1 页 / 共 4 页
字号:
🔍
1234 
      regE.Global = True ' 设置全局可用性。
      Matchess = regE.test(strng) ' 执行搜索。
      CheckExp = Matchess
   End Function 
   'HTML TO JS
   Function ToJs(Str) 
     Str=replace(Str,"</","<\/") 
     Str=replace(Str,chr(34),"\"&chr(34)) 
     Str=replace(Str,"'","\'") 
     Str=replace(Str,chr(13),""");") 
     Str=replace(Str,chr(10),chr(10)&"document.writeln(""") 
     If Str <> "" Then ToJs="document.writeln("""&Str&""");" Else ToJs = ""
   End Function
   '小数转换
  Function GetFormatNumber(Str,Num)
      If Str = "" or isnull(Str) or IsNumeric(Str)=False Then Exit Function
	  If Num = "" or isnull(Num) or IsNumeric(Num)=False Then Num = 0
	  Str = FormatNumber(Str,Num)
      If Split(Str,".")(0) = "" Then Str = "0."&Split(Str,".")(1)
	  GetFormatNumber = Str
  End Function
  '过滤SQL非法字符
  Function CheckStr(Strer,Num)
        Dim Shield,w
	    If Strer = "" Or IsNull(Strer) Then Exit Function
	    Select Case Num
		  Case 0 '一般
			Strer = Trim(Strer)
			Strer = Replace(Strer,CHR(39),"''")     '单引号
            Strer = Replace(Strer,CHR(34),"&quot;")    '双引号
            Strer = Replace(Strer,CHR(32),"&nbsp;")    '空格
            Strer = Replace(Strer,CHR(60),"&lt;")      '<
            Strer = Replace(Strer,CHR(62),"&gt;")      '>
			Strer = Replace(Strer,"--","—")     '单引号
            Strer = Replace(Strer,vbCrLf,"<br>")       
		  Case 1,8 '数字,支持小数
	        If IsNumeric(Strer) = 0 Then
	          Response.Write "操作错误"
		      Response.End
	        End If
		  Case 2'文本域提交
			Strer = Replace(Strer,CHR(39),"''")     '单引号
            Strer = Replace(Strer,CHR(34),"&quot;")    '双引号
            Strer = Replace(Strer,CHR(32),"&nbsp;")    '空格
            Strer = Replace(Strer,CHR(60),"&lt;")      '<
            Strer = Replace(Strer,CHR(62),"&gt;")      '>
            Strer = Replace(Strer,vbCrLf,"<br>")       
		  Case 3'文本域显示
			Strer = Replace(Strer,"&#39;",CHR(39))     '单引号
            Strer = Replace(Strer,"&quot;",CHR(34))    '双引号
            Strer = Replace(Strer,"&nbsp;",CHR(32))    '空格
            Strer = Replace(Strer,"&lt;",CHR(60))      '<
            Strer = Replace(Strer,"&gt;",CHR(62))      '>
            Strer = Replace(Strer,"<br>",vbCrLf)
          Case 4
            Strer = Replace(Strer, WR_Setting(4)&WR_UpLoad(0)&"/", "{$InstallDir}{$SiteUpDir}/")
            Strer = Replace(Strer, WR_Setting(3)&WR_UpLoad(0)&"/", "{$InstallDir}{$SiteUpDir}/")
          Case 5
            Strer = Replace(Strer, "{$InstallDir}{$SiteUpDir}/", WR_Setting(3)&WR_UpLoad(0)&"/")
          Case 6 '支持HTML
            Strer = Replace(Strer, Chr(39), "''")   '单引号
            Strer = Replace(Strer, vbCrLf, "<br>")
          Case 7
            Strer = Replace(Strer, "<br>", vbCrLf)
            Strer = Replace(Strer, "&#39;", Chr(39))   '单引号
          Case 9 '模板添加修改 转换单引号
            Strer = Replace(Strer, "'", "''")
          Case 10 '过滤内容中的框回页及js代码等
		    Strer = replace(Strer,"<ifrAme","&lt;ifrAme",1,-1,1) 
		    Strer = replace(Strer,"</ifrAme>","&lt;/ifrAme>",1,-1,1) 
		    Strer = replace(Strer,"<script","&lt;script",1,-1,1) 
		    Strer = replace(Strer,"</script>","&lt;/script>",1,-1,1) 
          Case 11 '显示时支持HTML
 			Strer = Replace(Strer,"&#39;",CHR(39))     '单引号
            Strer = Replace(Strer,"&quot;",CHR(34))    '双引号
            Strer = Replace(Strer,CHR(32),"&nbsp;")    '空格
            Strer = Replace(Strer, vbCrLf, "<br>")
		End Select
	    Shield = Split(WR_Setting(11),vbCrLf)
	    For w=0 To Ubound(Shield)
		  If Shield(w) <> "" Then
            If Instr(Shield(w),"=") > 0 Then Strer=Replace(Strer,Split(Shield(w),"=")(0),Split(Shield(w),"=")(1))
		  End If
	    Next
	    CheckStr = Strer
   End Function
   'UBB标签转换函数
   Function UBBCode(Str)
     If Str = "" Or IsNull(Str) Then UBBCode = "":Exit Function
     Dim Re
     Set Re=New RegExp
     Re.IgnoreCase =True
     Re.Global=True
     Re.Pattern = "^(http://[A-Za-z0-9\./=\?%\-&_~`@':+!]+)"
     Str = Re.Replace(Str,"<a target=_blank href=$1>$1</a>")
     Re.Pattern = "(http://[A-Za-z0-9\./=\?%\-&_~`@':+!]+)$"
     Str = Re.Replace(Str,"<a target=_blank href=$1>$1</a>")
     Re.Pattern = "([^>='])(http://[A-Za-z0-9\./=\?%\-&_~`@':+!]+)"
     Str = Re.Replace(Str,"$1<a target=_blank href=$2>$2</a>")
     Re.Pattern = "^(ftp://[A-Za-z0-9\./=\?%\-&_~`@':+!]+)"
     Str = Re.Replace(Str,"<a target=_blank href=$1>$1</a>")
     Re.Pattern = "(ftp://[A-Za-z0-9\./=\?%\-&_~`@':+!]+)$"
     Str = Re.Replace(Str,"<a target=_blank href=$1>$1</a>")
     Re.Pattern = "[^>='](ftp://[A-Za-z0-9\.\/=\?%\-&_~`@':+!]+)"
     Set Re=Nothing
	 UBBCode = Str
   End Function
   '======================================
   '取得用户点评转换的图片：GetRePic
   '======================================
   Function GetRePic(aStr)
     If aStr = "" Or IsNull(aStr) Then Exit Function
	 If IsNumeric(aStr) = False Then Exit Function
	 GetRePic = ""
	 aPic1 = "<img src='"&UrlPath&"Skins/"&WR_Setting(5)&"/icon_star_1.gif' align=absmiddle alt='"&aStr&"'>"
	 aPic2 = "<img src='"&UrlPath&"Skins/"&WR_Setting(5)&"/icon_star_2.gif' align=absmiddle alt='"&aStr&"'>"
	 aPic3 = "<img src='"&UrlPath&"Skins/"&WR_Setting(5)&"/icon_star_3.gif' align=absmiddle alt='"&aStr&"'>"
	 If aStr <= 10 Then
	   GetRePic = aPic1&aPic1&aPic1&aPic1&aPic1
	 ElseIf aStr <= 20 Then
	   GetRePic = aPic3&aPic1&aPic1&aPic1&aPic1
	 ElseIf aStr <= 30 Then
	   GetRePic = aPic2&aPic3&aPic1&aPic1&aPic1
	 ElseIf aStr <= 40 Then
	   GetRePic = aPic2&aPic2&aPic1&aPic1&aPic1
	 ElseIf aStr <= 50 Then
	   GetRePic = aPic2&aPic2&aPic3&aPic1&aPic1
	 ElseIf aStr <= 60 Then
	   GetRePic = aPic2&aPic2&aPic2&aPic1&aPic1
	 ElseIf aStr <= 70 Then
	   GetRePic = aPic2&aPic2&aPic2&aPic3&aPic1
	 ElseIf aStr <= 80 Then
	   GetRePic = aPic2&aPic2&aPic2&aPic2&aPic1
	 ElseIf aStr <= 90 Then
	   GetRePic = aPic2&aPic2&aPic2&aPic2&aPic3
	 ElseIf aStr <= 100 Then
	   GetRePic = aPic2&aPic2&aPic2&aPic2&aPic2
	 Else
	   GetRePic = aPic2&aPic2&aPic2&aPic2&aPic2
	 End If
   End Function
   '======================================
   '分类提取函数：SelectSort
   'aType 是否只显示内部栏目 1为是 0为否
   'IsMember：是否为会员中心，0为否，1为是，判断会员是否有权添加文章
   'SelectSize：下拉框内型，1为下拉框，>1为列表
   'Num：对应值，如果此值与列表中一个对应，则为selected
   'TableName：表名
   'FormName：表单名
   'Depth 栏目深度 0不限，1为只显示一级
   'IsDefault 显示列表时是否显示默认分类 0为不显示，1为显示 Nnm>0 时无效
   '======================================
   Function SelectSort(aType,eChannelID,IsMember,SelectSize, Num, TableName, FormName, Depth, IsDefault)
      Dim A_IsDefault,A_i,a_Type,A_ChannelID
	  If aType = 1 Then a_Type = " and WM_Type=1" Else a_Type = ""
      If Depth > 0 Then Depth = " And WM_Depth <" & Depth Else Depth = ""
      If IsDefault > 0 Then A_IsDefault = ",WM_IsDefault" Else A_IsDefault = ""
      If eChannelID > 0 Then A_ChannelID = " and WM_ChannelID = "&eChannelID Else A_ChannelID = ""
      SelectSort = SelectSort & "<select size=" & SelectSize & " name='" & FormName & "' style='font: 12px Tahoma, Verdana;font-weight: normal'>" & vbCrLf
      SelectSort = SelectSort & "<option></option>" & vbCrLf
      Set aRs = Conn.Execute("Select WM_ID,WM_ParentPath,WM_Depth,WM_Child,WM_Name" & A_IsDefault & ",WM_MemberFlag from " & TableName & " Where WM_ID Is Not Null "&A_ChannelID & a_Type & Depth & " Order By WM_ClassID,WM_Taxis")
      If aRs.EOF Then
        SelectSort = SelectSort & "<option value=0>请先添加分类</option>" & vbCrLf
      Else
        Do While Not aRs.EOF
		If IsMember > 0 and aRs(6) = 0 Then
		  SelectSort = SelectSort & "<optgroup label='"
		Else
          SelectSort = SelectSort & "<option value=" & aRs(0)
          If Num > 0 Then
            If Int(Num) = aRs(0) Then SelectSort = SelectSort & " selected"
          Else
            If IsDefault > 0 Then
              If aRs(5) > 0 Then SelectSort = SelectSort & " selected"
            End If
          End If
          SelectSort = SelectSort & ">"
		End If
        If aRs(2) > 0 Then
          For A_i = 1 To aRs(2)
            SelectSort = SelectSort & "　"
          Next
        End If
        If aRs(2) > 0 Then SelectSort = SelectSort & "- " Else SelectSort = SelectSort & "+ "
        SelectSort = SelectSort & aRs(4)
		If IsMember > 0 and aRs(6) = 0 Then SelectSort = SelectSort & "'>" Else SelectSort = SelectSort & "</option>"
        aRs.MoveNext
        Loop
     End If
     aRs.Close
     SelectSort = SelectSort & "</select>" & vbCrLf
   End Function
   '标签中使用CSS的判断显示
   Function LabelCss(Str)
     If Str <> "" Then LabelCss = " Class='"&Str&"'" Else LabelCss = ""
   End Function

   '发送邮件
   Function SendMail(mailbody,FromName,Subject,Email)
     Dim Mailer
	 If Email <> "" Then
	  Select Case WR_Mail(5)
	    Case "Jmail"
		  On Error Resume Next
	      Set Mailer = Server.CreateObject("jmail.Message")
	      Mailer.silent=true
	      Mailer.Logging = True
	      Mailer.Charset = "gb2312"
	      Mailer.MailServerUserName = WR_Mail(1) '您的邮件服务器登录名
	      Mailer.MailServerPassword = WR_Mail(2) '登录密码
	      Mailer.Priority = 1
	      Mailer.From = WR_Mail(3)
	      Mailer.FromName = FromName         '网站名称
	      Mailer.AddRecipient Email
	      Mailer.Subject = Subject
	      Mailer.Body = Mailbody
          Mailer.MailDomain = WR_Mail(3)         '邮件域名
	      Mailer.Send (WR_Mail(0))               'SMTP服务器
	      Set Mailer = Nothing
		  If Err Then SendMail = False Else SendMail = True
		Case "Cdonts"
		  On Error Resume Next
	      Set Mailer = Server.CreateObject("CDONTS.NewMail")
	      Mailer.From = WR_Mail(3)
	      Mailer.To = Email
	      Mailer.Subject = Subject
	      Mailer.BodyFormat = 0 
	      Mailer.MailFormat = 0 
	      Mailer.Body = Mailbody
	      Mailer.Send
	      Set Mailer = Nothing
		  If Err Then SendMail = False Else SendMail = True
	    Case "AspEmail"
		  On Error Resume Next
	      Set Mailer = Server.CreateObject("Persits.MailSender")
	      Mailer.Charset = "gb2312"
	      Mailer.IsHTML = False
	      Mailer.username = WR_Mail(1)        	'服务器上有效的用户名
	      Mailer.password = WR_Mail(2)          '服务器上有效的密码
	      Mailer.Priority = 1
	      Mailer.Host = WR_Mail(0)              'SMTP服务器
	      Mailer.Port = 25                              '该项可选.端口25是默认值
	      Mailer.From = WR_Mail(3)
	      Mailer.FromName = WR_Setting(0)             '该项可选
	      Mailer.AddAddress Email,Email
	      Mailer.Subject = Subject
	      Mailer.Body = Mailbody
	      Mailer.Send
	      Set Mailer = Nothing
		  If Err Then SendMail = False Else SendMail = True
		Case Else
		  SendMail = False
	  End Select
	 End If
   End Function
   '标签转换函数
   Function GetReplace(aStr,aLabel,aResult)
	  If aStr = "" Or IsNull(aStr) Then Exit Function
	  If aResult <> "" Or IsNull(aResult)=False Then  GetReplace = Replace(aStr,aLabel,aResult) Else GetReplace = Replace(aStr,aLabel,"")
   End Function
   '百分数转换
   Function GetFormatpercent(Str)
     If IsNumeric(Str) = False Then Exit Function
     Str = Formatpercent(Str)
	 If Split(Str,".")(0) = "" Then Str = "0"&Str
	 GetFormatpercent = Str
   End Function
   '转换函数
   Function GetHtmlEncode(aStr)
	  If aStr = "" Or IsNull(aStr) Then Exit Function
	  GetHtmlEncode = Server.HTMLEncode(aStr)
   End Function
   '信息截取 aType 1 标签前 2标签中 3标签后
   Function HCode(aType,aStr,aB,aE)
     If aStr="" or IsNull(aStr)=True Then HCode="":Exit Function
	 If aB="" or IsNull(aB)=True Or aE="" or IsNull(aE)=True Then HCode=aStr:Exit Function
	 aStr = "@@@@@@"&aStr&"@@@@@@"
     regE.Pattern="([\s\S]+?)("&aB&")([\s\S]+?)("&aE&")([\s\S]+)"
     Set Matchess = regE.Execute(aStr)
     For Each Matchs in Matchess
       Select Case aType
	     Case 1
	       HCode = regE.Replace(Matchs.Value,"$1")
	     Case 2
	       HCode = regE.Replace(Matchs.Value,"$3")
	     Case 3
	       HCode = regE.Replace(Matchs.Value,"$5")
	   End Select
     Next
	 HCode = GetReplace(HCode,"@@@@@@","")
   End Function
   'url解码
   Function URLDecode(aStr)
    alStr=""
    aSpecial="!""#$%&'()*+,.-_/:;<=>?@[\]^`{|}~%"
    For aI=1 to len(aStr)
      aC=Mid(aStr,aI,1)
      If aC="%" Then
        aV=eval("&h"+Mid(aStr,aI+1,2))
        If inStr(aSpecial,chr(aV))>0 Then
          alStr=alStr&chr(aV)
          aI=aI+2
        Else
          aV=eval("&h"+ Mid(aStr,aI+1,2) + Mid(aStr,aI+4,2))
          alStr=alStr & chr(aV)
          aI=aI+5
        End If
      Else
        If aC="+" Then
          alStr=alStr&" "
        Else
          alStr=alStr&aC
        End If
      End If
    Next
    URLDecode=alStr
   End function
   '禁止外部提交数据
   Sub CheckSubmit()
      If Mid(Cstr(Request.ServerVariables("HTTP_REFERER")),8,len(Cstr(Request.ServerVariables("SERVER_NAME"))))<>Cstr(Request.ServerVariables("SERVER_NAME")) Then 
         Call ErrView("·禁止从外部提交数据",0)
	  End If
	  If IsEmpty(GetCookies("Sift")) Then SCookies "Sift",MD5(0,Request.ServerVariables("Remote_Addr")&Request.Servervariables("LOCAL_ADDR")),1
	  If Ucase(GetCookies("Sift")) <> Ucase(MD5(0,Request.ServerVariables("Remote_Addr")&Request.Servervariables("LOCAL_ADDR"))) Then Call ErrView("·禁止发布垃圾信息",0)
   End Sub
   '是否在本地测试
1234

⌨️ 快捷键说明

复制代码 Ctrl + C
搜索代码 Ctrl + F
全屏模式 F11
切换主题 Ctrl + Shift + D
显示快捷键 ?
增大字号 Ctrl + =
减小字号 Ctrl + -