📄 cls.common.asp
字号:
GetShowUrl = UrlPath & GetShowUrl & GetReplace(GetReplace(GetReplace(GetReplace(aTime,"-","")," ",""),":",""),"/","") & aID & "/Index." & aRs(3)
Case 1
GetShowUrl = UrlPath & GetShowUrl & GetReplace(GetReplace(GetReplace(GetReplace(aTime,"-","")," ",""),":",""),"/","") & aID & "/"
End Select
End If
End Select
Case 1
Select Case aRs(2) '文件名
Case 7
GetShowUrl = WR_Setting(3) & GetShowUrl & aID & "/"
Case 8
GetShowUrl = WR_Setting(3) & GetShowUrl & GetReplace(GetReplace(GetReplace(GetReplace(aTime,"-","")," ",""),":",""),"/","") & "/"
Case Else
GetShowUrl = WR_Setting(3) & GetShowUrl
End Select
Case 2
Select Case aRs(2) '文件名
Case 1
GetShowUrl = WR_Setting(3) & GetShowUrl & aID & aPNum & "." & aRs(3)
Case 2
GetShowUrl = WR_Setting(3) & GetShowUrl & GetReplace(GetReplace(GetReplace(GetReplace(aTime,"-","")," ",""),":",""),"/","") & aID & aPNum & "." & aRs(3)
Case 3
GetShowUrl = WR_Setting(3) & GetShowUrl & Split(aDir,"/")(0) & "_" & aID & aPNum & "." & aRs(3)
Case 4
GetShowUrl = WR_Setting(3) & GetShowUrl & Split(aDir,"/")(0) & "_" & GetReplace(GetReplace(GetReplace(GetReplace(aTime,"-","")," ",""),":",""),"/","") & aPNum & "." & aRs(3)
Case 5
GetShowUrl = WR_Setting(3) & GetShowUrl & GetReplace(GetReplace(GetReplace(GetReplace(aTime,"-","")," ",""),":",""),"/","") & "_" & aID & aPNum & "." & aRs(3)
Case 6
GetShowUrl = WR_Setting(3) & GetShowUrl & Split(aDir,"/")(0) & "_" & GetReplace(GetReplace(GetReplace(GetReplace(aTime,"-","")," ",""),":",""),"/","") & "_" & aID & aPNum & "." & aRs(3)
Case 7
GetShowUrl = WR_Setting(3) & GetShowUrl & aID & "/Index"&aPNum&"." & aRs(3)
Case 8
GetShowUrl = WR_Setting(3) & GetShowUrl & GetReplace(GetReplace(GetReplace(GetReplace(aTime,"-","")," ",""),":",""),"/","") & aID & "/Index"&aPNum&"." & aRs(3)
End Select
End Select
End Select
End If
aRs.Close
If GetShowUrl = "" Then GetShowUrl = "#"
End Function
'###########################################################################################
'得到当前位置
'aType 类型 为0则补上地区
Function GetSitePath(aType,Str)
aCity = ""
Select Case aType
Case -1 '不补地区
aCity = ""
Case 0 '补上当前地区
aCityID = MyCityID
If aCityID = "" Then aCityID = 0
If aCityID > 0 Then aCity = GetAreaUrl(aCityID,"Name")
If aCity <> "" Then aCity = ",<a href="&GetAreaUrl(aCityID,"Url")&" target=_blank>"&aCity&"</a>"
Case Else '按aType补上实际地区
aCity = GetAreaUrl(aType,"Name")
If aCity <> "" Then aCity = ",<a href="&GetAreaUrl(aType,"Url")&" target=_blank>"&aCity&"</a>"
End Select
GetSitePath = Replace(WR_Setting(16)&"<a href="&UrlPath&" target=_parent>"&WR_Setting(0)&"</a>"&aCity&Str,",",WR_Setting(17))
End Function
'操作显示 NUM 0错 1对 2只显示Str内容
Function ErrView(Str,Num)
Call ClassEnd()
With Response
.Write "<link href="&UrlPath&"Skins/"&WR_Setting(5)&"/Style.css rel=stylesheet type=text/css>"
.Write "<Script language='JavaScript' Src='"&UrlPath&"Inc/Site.Js'></Script>"
.Write "<title>提示信息</title>"
If Num <> 2 Then
.Write "<table width='100%' height='100%' border=0 cellspacing=0 cellpadding=0><tr><td>"
.Write "<table align=center border=0 cellpadding=5 cellspacing=0 width='400' style='border:1px #CCCCCC solid;'>"
.Write "<tr><td height=22 style='border-bottom:1px #CCCCCC solid;padding:2px;background-color:#EFEFEF'> <b>友情提示：</b></td></tr>"
.Write "<tr><td valign=top style='padding:10px 0 0 0;'>"
.Write "<table width='80%' border=0 cellspacing=0 cellpadding=0 align=center><tr><td>"
.Write Str
.Write "<br><br>·<a href=# Onclick=""javascript:history.back()"" style='cursor:pointer'>返回上一页</a>"
.Write "<br>·<a href=# Onclick=""javascript:window.parent.close()"" style='cursor:pointer'>关闭当前页</a>"
.Write "</td></tr></table>"
.Write "</td></tr>"
.Write "<tr><td style='padding:10px 0 0 0;text-align:center;'><a href='http://www.wangren.net' target=_blank style='color:#CCCCCC'>Powered By WRMPS "&SystemVersion&"</a></td></tr>"
.Write "</table>"
.Write "</td></tr></table>" & vbCrLf
Else
.Write Str
End IF
.End
End With
End Function
Sub AjaxLogin(Url,Iframe,Str)
Call ClassEnd()
If Iframe = 1 Then Response.Redirect UrlPath&"login.asp?Action=Ajax&Str="&Str&"&ComeUrl="&Url:Response.end
With Response
.Write "<link href="&UrlPath&"Skins/"&WR_Setting(5)&"/Style.css rel=stylesheet type=text/css>"
.Write "<Script language='JavaScript' Src='"&UrlPath&"Inc/Site.Js'></Script>"
.Write "<title>提示信息</title>"
.Write "<table width='100%' height='100%' border=0 cellspacing=0 cellpadding=0><tr><td>"
.Write "<table align=center border=0 cellpadding=5 cellspacing=0 width='400' style='border:1px #CCCCCC solid;'>"
.Write "<tr><td height=22 style='border-bottom:1px #CCCCCC solid;padding:2px;background-color:#EFEFEF'> <b>友情提示：</b></td></tr>"
.Write "<tr><td valign=top style='padding:10px 0 0 0;'>"
.Write "<table width='80%' border=0 cellspacing=0 cellpadding=0 align=center><tr><td>"
.Write "您需要登录后才可以进行此操作"
.Write "<br><br>·<a href=# Onclick=""javascript:history.back()"" style='cursor:pointer'>返回上一页</a>"
.Write "<br>·<a href=# Onclick=""javascript:window.parent.close()"" style='cursor:pointer'>关闭当前页</a>"
.Write "</td></tr></table>"
.Write "</td></tr>"
.Write "<tr><td style='padding:10px 0 0 0;text-align:center;'><a href='http://www.wangren.net' target=_blank style='color:#CCCCCC'>Powered By WRMPS "&SystemVersion&"</a></td></tr>"
.Write "</table>"
.Write "</td></tr></table>" & vbCrLf
.Write "<script>" & vbCrLf
.Write "function AjaxLogin(){" & vbCrLf
.Write "parent.openWithIframe('用户登录','"&UrlPath&"login.asp?Action=Ajax&Str="&Str&"&ComeUrl="&Url&"',450,180);" & vbCrLf
.Write "}" & vbCrLf
.Write "AjaxLogin();" & vbCrLf
.Write "</script>" & vbCrLf
.End
End With
End Sub
Sub Loading(Str)
If Str = "" Then Str = "数据处理中，请稍候..."
With Response
.Write "<div id=Loading style='height:100%;width:100%;position:absolute;display:none'>" & vbCrLf
.Write "<table border=0 width='100%' height='100%' align='center'><tr><td>" & vbCrLf
.Write "<table border=0 cellpadding=0 cellspacing=0 width='300px' height='150px' align='center'>" & vbCrLf
.Write "<tr><td style='border:1px #666666 solid;background:#FFFFFF' align=center><img src='"&UrlPath&"Skins/"&WR_Setting(5)&"/loading.gif' align=absmiddle> "&Str&"</td></tr>" & vbCrLf
.Write "</table></td></tr></table></div>" & vbCrLf
End With
End Sub
'=====================================
'通用分页 GetPageList
'URLParameter 控制参数
'PageValue:每页显示记录数
'RetCount:总记录数
'CurrentPage:当前页数
'=====================================
Function GetPageList(URLParameter,PageValue,retCount,CurrentPage)
Dim aTempUrl
aUrl = "":aTempUrl=""
Dim M_Url
PageValue=Int(PageValue)
If RetCount="" Then RetCount = 0
RetCount=Int(RetCount)
If CurrentPage="" Then CurrentPage=0
CurrentPage=Int(CurrentPage)
If RetCount > 0 Then
If (RetCount Mod PageValue) = 0 Then PagesCount = RetCount \ PageValue Else PagesCount = (RetCount \ PageValue)+1
If PageName = "" Then PageName = "/"&Right(Request.ServerVariables("url"),Len(Request.ServerVariables("url"))-1)
If aTempUrl = "" Then aTempUrl = Request.QueryString
aTempUrl = Split(aTempUrl,"&")
For aN = 0 To UBound(aTempUrl)
If aTempUrl(aN) <> "" and Instr(Ucase("&"&aTempUrl(aN)),"&PAGE=") = 0 Then
If aUrl = "" Then aUrl = aTempUrl(aN) Else aUrl = aUrl & "&" & aTempUrl(aN)
End If
Next
If URLParameter = "" Then URLParameter = aUrl
If URLParameter <> "" Then URLParameter = "&"&URLParameter:URLParameter = Replace(URLParameter,"&&","&")
PageContent = "<span class=Page>" & CurrentPage & "/" & PagesCount & "页</span>"
If CurrentPage > 1 Then
PageContent = PageContent & "<a href='"&PageName&"?Page=1" & URLParameter & "'><span class=Page>首页</span></a>"
PageContent = PageContent & "<a href='"&PageName&"?Page="&CurrentPage-1 & URLParameter & "'><span class=Page>上一页</span></a>"
For aN = CurrentPage-4 To CurrentPage-1
If aN > 0 Then
PageContent = PageContent & "<span class=Page><a href='"&PageName&"?Page=" &aN& URLParameter & "'>" & aN & "</a></span>"
End If
Next
End If
If PagesCount > 1 Then
PageContent = PageContent & "<span class=Page_1>" & CurrentPage & "</span>"
End If
If PagesCount-CurrentPage > 0 Then
For aN = CurrentPage+1 To CurrentPage+5
If aN <= PagesCount Then
PageContent = PageContent & "<span class=Page><a href='"&PageName&"?Page=" &aN& URLParameter & "'>" & aN & "</a></span>"
End If
Next
PageContent = PageContent & "<a href='"&PageName&"?Page=" &CurrentPage+1& URLParameter & "'><span class=Page>下一页</span></a>"
PageContent = PageContent & "<a href='"&PageName&"?Page=" &PagesCount& URLParameter & "'><span class=Page>尾页</span></a>"
End If
End If
GetPageList = PageContent
End Function
'======================================
'内容分页函数：ContentPageNext
'FileName 页面文件名
'PageNum 页码
'ArticleContent：待分页的内容
'PageNext：分页模式 '0不分页 1自动分页 2手动分页
'MaxCharPerPage：自动分页时每页最大字符数
'======================================
Function ContentPageNext(FileName,PageNum,FormaArticleContent,PageNext,MaxCharPerPage,aID)
Dim aBeginStr,aI,aPageList,aContentPage,aArticleContent,aFileName
aArticleContent = FormaArticleContent
Select Case PageNext
Case 1 '1自动分页
If MaxCharPerPage = "" Then MaxCharPerPage = 5000
If MaxCharPerPage <= 0 Then MaxCharPerPage = 5000
If Instr(Round(Len(aArticleContent)/MaxCharPerPage,1),".") > 0 Then:If Split(Round(Len(aArticleContent)/MaxCharPerPage,1),".")(0) = "" Then:aContentPage = 1:Else:aContentPage = Int(Split(Round(Len(aArticleContent)/MaxCharPerPage,1),".")(0)) + 1:End If:Else:aContentPage = Int(Round(Len(aArticleContent)/MaxCharPerPage,1)):End If
If aContentPage > 1 Then
Page = CheckStr(Request("Page"),1)
If Page = "" Then Page = 1
If Page < 1 Then Page = 1
If PageNum > 1 Then Page = PageNum
Page = Int(Page)
If aContentPage < Page Then Page = aContentPage
If Page = 1 Then aBeginStr = 1 Else aBeginStr = (MaxCharPerPage*(Page-1))+1
aArticleContent = Mid(aArticleContent,aBeginStr,MaxCharPerPage)
If Int(WR_Setting(9)) = 1 Then aFileName = UrlPath&ChannelDir&"_"&aID&"_"&Page-1&"/" Else If FileName <> "" Then:If Page-1 > 1 Then:aFileName = Left(FileName,Len(FileName)-(Len(Split(FileName,".")(UBound(Split(FileName,"."))))+1))&"_"&Page-1&"."&Split(FileName,".")(UBound(Split(FileName,"."))):Else:aFileName = FileName:End If:Else:aFileName = "Show.asp?ID="&aID&"&Page="&Page-1:End If
If page > 1 Then aPageList = "<a href="&aFileName&"><img src='"&UrlPath&"Skins/"&WR_Setting(5)&"/Prev.gif' border=0 align=absmiddle></a> " Else aPageList = "<img src='"&UrlPath&"Skins/"&WR_Setting(5)&"/Prev.gif' border=0 align=absmiddle> "
For aI = 1 To aContentPage
If Page = aI Then
aPageList = aPageList & "<font color=red>["&aI&"]</font> "
Else
If Int(WR_Setting(9)) = 1 Then aFileName = UrlPath&ChannelDir&"_"&aID&"_"&aI&"/" Else aFileName = "":If FileName <> "" Then:If aI > 1 Then:aFileName = Left(FileName,Len(FileName)-(Len(Split(FileName,".")(UBound(Split(FileName,"."))))+1))&"_"&aI&"."&Split(FileName,".")(UBound(Split(FileName,"."))):Else:aFileName = FileName:End If:Else:aFileName = "Show.asp?ID="&aID&"&Page="&aI:End If
aPageList = aPageList & "<a href="&aFileName&">["&aI&"]</a> "
End If
Next
If Int(WR_Setting(9)) = 1 Then aFileName = UrlPath&ChannelDir&"_"&aID&"_"&Page+1&"/" Else aFileName = "":If FileName <> "" Then:If Page+1 > 1 Then:aFileName = Left(FileName,Len(FileName)-(Len(Split(FileName,".")(UBound(Split(FileName,"."))))+1))&"_"&Page+1&"."&Split(FileName,".")(UBound(Split(FileName,"."))):Else:aFileName = FileName:End If:Else:aFileName = "Show.asp?ID="&aID&"&Page="&Page+1:End If
If page < aContentPage Then aPageList = aPageList & "<a href="&aFileName&"><img src='"&UrlPath&"Skins/"&WR_Setting(5)&"/Next.gif' border=0 align=absmiddle></a>" Else aPageList = aPageList & "<img src='"&UrlPath&"Skins/"&WR_Setting(5)&"/Next.gif' border=0 align=absmiddle>"
aArticleContent = aArticleContent & "<br><br><div align=center>"&aPageList&"</div><br>"
End If
Case 2 '2手动分页
If InStr(aArticleContent,"[NextPage]") > 0 Then
aContentPage = UBound(Split(aArticleContent,"[NextPage]"))+1
End If
Page=CheckStr(Request("Page"),1)
If Page = "" Then Page = 1
If Page < 1 Then Page = 1
If PageNum > 1 Then Page = PageNum
Page = Int(Page)
If aContentPage < Page Then Page = aContentPage
If aContentPage > 1 Then
aBeginStr = Split(aArticleContent,"[NextPage]")
aArticleContent = aBeginStr(Page-1)
If Int(WR_Setting(9)) = 1 Then aFileName = UrlPath&ChannelDir&"_"&aID&"_"&Page-1&"/" Else If FileName <> "" Then:If Page-1 > 1 Then:aFileName = Left(FileName,Len(FileName)-(Len(Split(FileName,".")(UBound(Split(FileName,"."))))+1))&"_"&Page-1&"."&Split(FileName,".")(UBound(Split(FileName,"."))):Else:aFileName = FileName:End If:Else:aFileName = "Show.asp?ID="&aID&"&Page="&Page-1:End If
If page > 1 Then aPageList = "<a href="&aFileName&"><img src='"&UrlPath&"Skins/"&WR_Setting(5)&"/Prev.gif' border=0 align=absmiddle></a> " Else aPageList = "<img src='"&UrlPath&"Skins/"&WR_Setting(5)&"/Prev.gif' border=0 align=absmiddle> "
For aI = 1 To aContentPage
If Page = aI Then
aPageList = aPageList & "<font color=red>["&aI&"]</font> "
Else
If Int(WR_Setting(9)) = 1 Then aFileName = UrlPath&ChannelDir&"_"&aID&"_"&aI&"/" Else aFileName = "":If FileName <> "" Then:If aI > 1 Then:aFileName = Left(FileName,Len(FileName)-(Len(Split(FileName,".")(UBound(Split(FileName,"."))))+1))&"_"&aI&"."&Split(FileName,".")(UBound(Split(FileName,"."))):Else:aFileName = FileName:End If:Else:aFileName = "Show.asp?ID="&aID&"&Page="&aI:End If
aPageList = aPageList & "<a href="&aFileName&">["&aI&"]</a> "
End If
Next
If Int(WR_Setting(9)) = 1 Then aFileName = UrlPath&ChannelDir&"_"&aID&"_"&Page+1&"/" Else aFileName = "":If FileName <> "" Then:If Page+1 > 1 Then:aFileName = Left(FileName,Len(FileName)-(Len(Split(FileName,".")(UBound(Split(FileName,"."))))+1))&"_"&Page+1&"."&Split(FileName,".")(UBound(Split(FileName,"."))):Else:aFileName = FileName:End If:Else:aFileName = "Show.asp?ID="&aID&"&Page="&Page+1:End If
If Page < aContentPage Then aPageList = aPageList & "<a href="&aFileName&"><img src='"&UrlPath&"Skins/"&WR_Setting(5)&"/Next.gif' border=0 align=absmiddle></a>" Else aPageList = aPageList & "<img src='"&UrlPath&"Skins/"&WR_Setting(5)&"/Next.gif' border=0 align=absmiddle>"
aArticleContent = aArticleContent & "<br><br><div align=center>"&aPageList&"</div><br>"
End If
End Select
ContentPageNext = aArticleContent
End Function
'截取字符长度 Str 字符 StrLen 字符长度 Ellipsis 要不要省略号 1为要，0为不要
Function GotTopic(Str,StrLen,Ellipsis)
Dim GTopicLen,GTopicT,GTopicN,GTopicI
If Str="" Or IsNull(Str) Or StrLen < 1 Then:GotTopic="" : Exit Function :End If
Str=Replace(Replace(Replace(Replace(str," "," "),""",Chr(34)),">",">"),"<","<")
Str = LeachHTML(Str)
GTopicLen=Len(Str)
GTopicT=0
For GTopicI=1 To GTopicLen
GTopicN=Abs(Asc(Mid(Str,GTopicI,1)))
If GTopicN>255 Then
GTopicT=GTopicT+2
Else
GTopicT=GTopicT+1
End If
If GTopicT>=StrLen Then
If Ellipsis>0 Then
If Abs(Asc(Right(Left(Str,GTopicI),1))) > 255 Then
GotTopic=Left(Str,GTopicI-1)&"..."
Else
GotTopic=Left(Str,GTopicI-2)&"..."
End If
Else
GotTopic=Left(Str,GTopicI)
End If
Exit For
Else
GotTopic=Str
End If
Next
GotTopic=Replace(Replace(Replace(Replace(GotTopic," "," "),Chr(34),"""),">",">"),"<","<")
End Function
'获得字符长度
Function StrLength(Str)
If Str="" Or Isnull(Str) Then
StrLength=0
Exit Function
End If
Dim SLLen,SLT,SLN,SLI
Str=Cstr(Str)
Str=Replace(Replace(Replace(Replace(Str," "," "),""",Chr(34)),">",">"),"<","<")
SLLen=Len(Str)
SLT=0
For SLI=1 To SLLen
SLN=Abs(Asc(Mid(Str,SLI,1)))
If SLN>255 Then
SLT=SLT+2
Else
SLT=SLT+1
End If
Next
StrLength=Int(SLT)
End Function
'过滤HTML
Function LeachHTML(str)
If Str="" or Isnull(Str) Then Exit Function
LeachHTML = GetReplace(str,"javascript:if(this.width>500){this.width=500};if(this.height>500){this.height=500;}","DrawImage(this, 500, 500)")
regE.IgnoreCase = True
regE.Global = True
regE.Pattern = "<\/*[^<>]*>"
LeachHTML = regE.Replace(LeachHTML,"")
LeachHTML = GetReplace(LeachHTML," ","")
LeachHTML = GetReplace(LeachHTML," ","")
LeachHTML = GetReplace(LeachHTML," ","")
LeachHTML = GetReplace(LeachHTML,vbCrLf,"")
LeachHTML = GetReplace(LeachHTML,"[NextPage]","")
LeachHTML = Trim(LeachHTML)
End Function
'检测是否包含 patrn
Function CheckExp(patrn, strng)
regE.Pattern = patrn ' 设置模式。
regE.IgnoreCase = true ' 设置是否区分字符大小写。
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -