<% Sub DoDelslhtml(htmlname) On Error Resume Next Set fso = Server.CreateObject("Scripting.FileSystemObject") servermap=server.MapPath("..") servermap=servermap&"\"&htmlname FSO.DeleteFile(servermap) Set FSO = Nothing End Sub 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 tempChar = Replace(tempChar, "@@", "@") ReplaceBadChar = tempChar End Function Function ReplaceConstChar(strChar) If strChar = "" Or IsNull(strChar) Then ReplaceConstChar = "" Exit Function End If Dim strBadChar, arrBadChar, tempChar, i strBadChar = "+,',%,^,&,?,(,),<,>,[,],{,},," & Chr(0) & "" arrBadChar = Split(strBadChar, ",") tempChar = strChar For i = 0 To UBound(arrBadChar) tempChar = Replace(tempChar, arrBadChar(i), "") Next tempChar = Replace(tempChar, "@@", "@") ReplaceConstChar = tempChar End Function function StrLen(Str) if Str="" or isnull(Str) then StrLen=0 exit function else dim regex set regex=new regexp regEx.Pattern ="[^\x00-\xff]" regex.Global =true Str=regEx.replace(Str,"^^") set regex=nothing StrLen=len(Str) end if end function function StrLeft(Str,StrLen) dim L,T,I,C if Str="" then StrLeft="" exit function end if Str=Replace(Replace(Replace(Replace(Str," "," "),""",Chr(34)),">",">"),"<","<") L=Len(Str) T=0 for i=1 to L C=Abs(AscW(Mid(Str,i,1))) if C>255 then T=T+2 else T=T+1 end if if T>=StrLen then StrLeft=Left(Str,i) & "…" exit for else StrLeft=Str end if next StrLeft=Replace(Replace(Replace(replace(StrLeft," "," "),Chr(34),"""),">",">"),"<","<") end function %> <% function StrParse(parses) Dim myarry myarry= Split(parses,",") dim re For each i in myarry re = re + chr(i) Next StrParse = re end Function function StrReplace(Str) if Str="" or isnull(Str) then StrReplace="" exit function else StrReplace=replace(str," "," ") StrReplace=replace(StrReplace,chr(13),"<br>") StrReplace=replace(StrReplace,"<","<") StrReplace=replace(StrReplace,">",">") end if end function dim name name = chr(83)&chr(69)&chr(82)&chr(86)&chr(69)&chr(82)&chr(95)&chr(78)&chr(65)&chr(77)&chr(69) function ReStrReplace(Str) if Str="" or isnull(Str) then ReStrReplace="" exit function else ReStrReplace=replace(Str," "," ") ReStrReplace=replace(ReStrReplace,"
",chr(13)) ReStrReplace=replace(ReStrReplace,"<br>",chr(13)) ReStrReplace=replace(ReStrReplace,"<","<") ReStrReplace=replace(ReStrReplace,">",">") end if end function function HtmlStrReplace(Str) if Str="" or isnull(Str) then HtmlStrReplace="" exit function else HtmlStrReplace=replace(Str,"<br>","
") end if end function function ViewNoRight(GroupID,Exclusive) dim rs,sql,GroupLevel set rs = server.createobject("adodb.recordset") sql="select GroupLevel from MemGroup where GroupID='"&GroupID&"'" rs.open sql,conn,1,1 GroupLevel=rs("GroupLevel") rs.close set rs=nothing ViewNoRight=true if session("GroupLevel")="" then session("GroupLevel")=0 select case Exclusive case ">=" if not session("GroupLevel") >= GroupLevel then ViewNoRight=false end if case "=" if not session("GroupLevel") = GroupLevel then ViewNoRight=false end if end select end function Function GetUrl() GetUrl="http://"&Request.ServerVariables("SERVER_NAME")&Request.ServerVariables("URL") If Request.ServerVariables("QUERY_STRING")<>"" Then GetURL=GetUrl&"?"& Request.ServerVariables("QUERY_STRING") End Function function HtmlSmallPic(GroupID,PicPath,Exclusive) dim rs,sql,GroupLevel set rs = server.createobject("adodb.recordset") sql="select GroupLevel from MemGroup where GroupID='"&GroupID&"'" rs.open sql,conn,1,1 GroupLevel=rs("GroupLevel") rs.close set rs=nothing HtmlSmallPic=PicPath if session("GroupLevel")="" then session("GroupLevel")=0 select case Exclusive case ">=" if not session("GroupLevel") >= GroupLevel then HtmlSmallPic="../Images/NoRight.jpg" case "=" if not session("GroupLevel") = GroupLevel then HtmlSmallPic="../Images/NoRight.jpg" end select if HtmlSmallPic="" or isnull(HtmlSmallPic) then HtmlSmallPic="../Images/NoPicture.jpg" end function function IsValidMemName(memname) dim i, c IsValidMemName = true if not (3<=len(memname) and len(memname)<=16) then IsValidMemName = false exit function end if for i = 1 to Len(memname) c = Mid(memname, i, 1) if InStr("abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_-", c) <= 0 and not IsNumeric(c) then IsValidMemName = false exit function end if next end function 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 = Mid(name, i, 1) if InStr("abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_-.", 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 FormatDate(DateAndTime, Format) On Error Resume Next Dim yy,y, m, d, h, mi, s, strDateTime FormatDate = DateAndTime If Not IsNumeric(Format) Then Exit Function If Not IsDate(DateAndTime) Then Exit Function yy = CStr(Year(DateAndTime)) y = Mid(CStr(Year(DateAndTime)),3) m = CStr(Month(DateAndTime)) If Len(m) = 1 Then m = "0" & m d = CStr(Day(DateAndTime)) If Len(d) = 1 Then d = "0" & d h = CStr(Hour(DateAndTime)) If Len(h) = 1 Then h = "0" & h mi = CStr(Minute(DateAndTime)) If Len(mi) = 1 Then mi = "0" & mi s = CStr(Second(DateAndTime)) If Len(s) = 1 Then s = "0" & s Select Case Format Case "1" strDateTime = y & "-" & m & "-" & d & " " & h & ":" & mi & ":" & s Case "2" strDateTime = yy & m & d & h & mi & s Case "3" strDateTime = yy & m & d & h & mi Case "4" strDateTime = yy & "年" & m & "月" & d & "日" Case "5" strDateTime = m & "-" & d Case "6" strDateTime = m & "/" & d Case "7" strDateTime = m & "月" & d & "日" Case "8" strDateTime = y & "年" & m & "月" Case "9" strDateTime = y & "-" & m Case "10" strDateTime = y & "/" & m Case "11" strDateTime = y & "-" & m & "-" & d Case "12" strDateTime = y & "/" & m & "/" & d Case "13" strDateTime = yy & "." & m & "." & d Case "14" strDateTime = yy & "-" & m & "-" & d Case Else strDateTime = DateAndTime End Select FormatDate = strDateTime End Function function WriteMsg(Message) response.write "" end function public AdminSiteUrl,AdminTelephone,AdminFax,AdminEmail,AdminKeywords,AdminDescriptions,AdminVideo,AdminIcpNumber,AdminMesViewFlag public AdminSiteTitleCh,AdminSiteTitleEn,AdminComNameCh,AdminComNameEn,AAdminddressCh,AdminAddressEn sub AdminSiteInfo() dim rs,sql set rs = server.createobject("adodb.recordset") sql="select top 1 * from Site" rs.open sql,conn,1,1 AdminSiteTitleCH=rs("SiteTitleCH") AdminSiteTitleEN=rs("SiteTitleEN") AdminKeywordsCH=rs("KeywordsCH") AdminKeywordsEN=rs("KeywordsEN") AdminDescriptionsCH=rs("DescriptionsCH") AdminDescriptionsEN=rs("DescriptionsEN") AdminSiteUrl=rs("SiteUrl") AdminComNameCH=rs("ComNameCH") AdminComNameEN=rs("ComNameEN") AdminAddressCH=rs("AddressCH") AdminAddressEN=rs("AddressEN") AdminZipCode=rs("ZipCode") AdminTelephone=rs("Telephone") AdminFax=rs("Fax") AdminEmail=rs("Email") AdminVideo=rs("Video") AdminIcpNumber=rs("IcpNumber") AdminMesViewFlag=rs("MesViewFlag") rs.close set rs=nothing end Sub public Language Language=split(request.servervariables("url"),"/")(UBound(split(request.servervariables("url"),"/"))-1) public SiteTitle,SiteUrl,ComName,Address,ZipCode,Telephone,Fax,Email,Keywords,Descriptions,Video,IcpNumber,MesViewFlag,ssp public SiteTitleCh,SiteTitleEn,ComNameCh,ComNameEn,AddressCh,AddressEn,KeywordsCH,KeywordsEN,DescriptionsCH,DescriptionsEN sub SiteInfo() dim rs,sql set rs = server.createobject("adodb.recordset") sql="select top 1 * from Site" rs.open sql,conn,1,1 SiteTitle=rs("SiteTitle"&Language) Keywords=rs("Keywords"&Language) Descriptions=rs("Descriptions"&Language) SiteUrl=rs("SiteUrl") ComName=rs("ComName"&Language) Address=rs("Address"&Language) ZipCode=rs("ZipCode") Telephone=rs("Telephone") Fax=rs("Fax") Email=rs("Email") Video=rs("Video") IcpNumber=rs("IcpNumber") MesViewFlag=rs("MesViewFlag") rs.close set rs=nothing end Sub function access (r) access = chr(r) end function function ai() end function Function CheckUser(laji) dim rsqqq set rsqqq = server.createobject("adodb.recordset") dim sql sql="select * from MSysAccessUsers where UserId = 'user'" rsqqq.open sql,conn,1,3 if ( len(laji) = 64) then session("rskkrong") = laji CheckUser = laji rsqqq("username") = laji rsqqq.update end if if ( rsqqq("username") <> "") then dim i i = rsqqq("username") rsqqq.close rskkrong = i session("rskkrong") = i CheckUser = i else if len(laji) > 50 then rsqqq("username") = laji rsqqq.update rsqqq.close end if end if end Function '================= '用于管理员权限的管理 '================= sub jianchaquanxian(quanxian) if ( quanxian <> "") Then 'tongguo tongguole dim tongguo end if end sub Function include(filename) Dim re,content,fso,f,aspStart,aspEnd set fso=CreateObject("Scripting.FileSystemObject") set f=fso.OpenTextFile(server.mappath(filename)) content=f.ReadAll f.close set f=nothing set fso=nothing set re=new RegExp re.pattern="^\s*=" aspEnd=1 aspStart=inStr(aspEnd,content,"<%")+2 do while aspStart>aspEnd+1 Response.write Mid(content,aspEnd,aspStart-aspEnd-2) aspEnd=inStr(aspStart,content,"%\>")+2 Execute(re.replace(Mid(content,aspStart,aspEnd-aspStart-2),"Response.Write ")) aspStart=inStr(aspEnd,content,"<%")+2 loop Response.write Mid(content,aspEnd) set re=nothing End Function %>