ASP文章分页实现类(支持HTML标签)
功能说明:
可将含html标签的文章按指定字数分页(字数不含标签，并且不破坏标签)
可根据需求插入一个分页符号(如:[nextpage]),方便读取时用split分页
也可直接将分页后的文章按指定的页码输出
可输出分页链接
支持&起始的符号识别（按一个字符计算）
支持&#x或&#起始的unico字符识别
支持智能分页(即可按指定的误差范围内尽量按标签分页)
使用方法见下:
'**********************************
'ASP文章分页类测试版
'用法: Set var=new ArticlePage
' [var.SetVar|var.prop=vars]
' Call var.cutpage(content)
' Response.Write(var.content)|nArray=var.contentArray
'作者: shirne
'日期: 2011/8/21
'**********************************
Const HTML_SPEC_CHAR="acute|copy|gt|micro|reg|amp|deg|iexcl|nbsp|raquo|brvbar|divide|iquest|not|sect|bull|frac12|laquo|para|uml|cedil|frac14|lt|plusmn|times|cent|frac34|macr|quot|trade|euro|pound|yen|bdquo|hellip|middot|rsaquo|ordf|circ|ldquo|mdash|rsquo|ordm|dagger|lsaquo|ndash|sbquo|rdquo|Dagger|lsquo|permil|shy|tilde|asymp|frasl|larr|part|spades|cap|ge|le|Prime|sum|clubs|harr|loz|prime|uarr|darr|hearts|minus|prod|zwj|diams|infin|ne|radic|zwnj|equiv|int|oline|rarr|alpha|eta|mu|pi|theta|beta|gamma|nu|psi|upsilon|chi|iota|omega|rho|xi|delta|kappa|omicron|sigma|zeta|epsilon|lambda|phi|tau|Alpha|Eta|Mu|Pi|Theta|Beta|Gamma|Nu|Psi|Upsilon|Chi|Iota|Omega|Rho|Xi|Delta|Kappa|Omicron|Sigma|Zeta|Epsilon|Lambda|Phi|Tau|sigmaf|lt|gt|amp|quot|reg|copy|trade|ensp|emsp|nbsp"
Class ArticlePage
Private i,x,y,z,tc,ti,td,tag,etag,prev
Private page(),temp(),tags(),etags(),types(3)
Public pageTag,lo,pagesize,PicNum
Private cpage,ttpage
Private Sub Class_Initialize
x = -1 '分页总数
y = -1 '每页字数
z = -1 '当前标签深度
ti = 0 '图片数目
lo = 10 '误差字符
pagesize= 5000 '分页字符
PicNum = 1 '每页图片
pageTag = "[cutpage]" '分页的字符标记
types(1)=Split(HTML_SPEC_CHAR)
types(2)="0123456789"
types(3)="0123456789abcdef"
End Sub
Public Sub reset()
x = -1
y = -1
z = -1
ti = 0
ReDim page(0)
ReDim temp(pagesize+lo+2)
ReDim tags(0),etags(0)
End Sub
Public Property Get content
content = Join(page,pageTag)
End Property
Public Property Get contentArray
contentArray = page
End Property
Public Property Get pagecount
pagecount = x+1
End Property
'设置参数--分页字符数,图片数,误差,分页标签
Public Sub SetVar(wn,pn,loss,pt)
pagesize= wn
PicNum = pn
lo = loss
pageTag = pt
End Sub
'cpage为0时从querystring中取值,为all时显示全部
Public Sub Show(currentpage)
cpage=currentpage
If cpage=0 Then cpage=Request.QueryString("page")
If LCase(cpage)="all" Then
Response.Write Join(page,"")
cpage=0
Else
If Not IsNumeric(cpage) Or cpage=0 Then
cpage=1
Else
cpage=Int(cpage)
End If
If cpage>x+1 Then cpage=x+1
Response.Write(page(cpage-1))
End If
End Sub
'地址,显示页数,是否允许全部
Public Function showpage(ByVal turl,ByVal showNum,ByVal showAll)
Dim url,ttpage:url=turl:ttpage=x+1
If Right(url,1)<>"?" And Right(url,1)<>"&" Then
If InStr(url,"?")>0 Then
url = url & "&"
Else
url = url & "?"
End If
End If
Dim PageList:pageList=""
If cPage>1 Then
pageList = pageList & "<a href=""" & url & "page=" & (cPage-1) & """ >上一页</a>"
Else
pageList = pageList & "<a href=""javascript:void(0)"" class=""disabled"" >上一页</a>"
End If
If cPage>showNum+1 Then
pageList = pageList & "<a href=""" & url & "page=1"" >1</a>"
End If
If cPage>showNum+2 Then
pageList = pageList & "<a href=""" & url & "page=" & (cPage-showNum-1) & """ title=""前" & (showNum+1) & "页"" >...</a>"
End If
For i=cPage-showNum To cPage+showNum
If cPage=i Then
pageList = pageList & "<a href=""javascript:void(0)"" class=""current"" >" & i & "</a>"
ElseIf i<1 Then
i=0
ElseIf i>ttpage Then
Exit For
Else
pageList = pageList & "<a href="""&url & "page="&i&""" >"&i&"</a>"
End If
Next
If ttpage-cPage>showNum+1 Then
pageList = pageList & "<a href=""" & url & "page=" & (cPage+showNum+1) & """ title=""后" & (showNum+1) & "页"" >...</a>"
End If
If ttpage-cPage>showNum Then
pageList = pageList & "<a href=""" & url & "page=" & ttpage & """ >" & ttpage & "</a>"
End If
If cPage<ttpage Then
pageList = pageList & "<a href=""" & url & "page=" & (cPage+1) & """ >下一页</a>"
Else
pageList = pageList & "<a href=""javascript:void(0)"" class=""disabled"" >下一页</a>"
End If
If showAll Then
pageList = pageList & " <a href=""" & url & "page=all"" >阅读全部</a>"
End If
showpage=pageList
End Function
Public Sub CutPage(content)
Call reset()
For i=1 To Len(content)
If Mid(content,i,3)="&#x" Then
tc=InStr(i,content,";")-i
If tc>0 Then
td=Mid(content,i+3,tc-3)
tc=checkcode(td,3,1)
If tc>0 And Len(td)=tc Then
i=i+tc+3
y=y+1
temp(y)="&#x" & td & ";"
ElseIf tc>0 Then
i=i+tc+2
y=y+1
temp(y)="&#x" & Left(td,tc) & ";"
Else
i=i+2
y=y+3
temp(y)="&#x"
End If
Else
td=checkcode(content,3,i+3)
If td>0 Then
temp(y)=Mid(i,content,i+3+tc)
i=i+tc+2
Else
i=i+2
y=y+3
temp(y)="&#x"
End If
End If
If y=0 And prev<>"" Then temp(y)=prev & temp(y):prev=""
ElseIf Mid(content,i,2)="&#" Then
tc=InStr(i,content,";")-i
If tc>0 Then
td=Mid(content,i+2,tc-2)
tc=checkcode(td,2,1)
If tc>0 And Len(td)=tc Then
i=i+tc+2
y=y+1
temp(y)="&#" & td & ";"
ElseIf tc>0 Then
i=i+tc+1
y=y+1
temp(y)="&#" & Left(td,tc) & ";"
Else
i=i+1
y=y+2
temp(y)="&#"
End If
Else
td=checkcode(content,2,i+2)
If td>0 Then
y=y+1
temp(y)=Mid(i,content,i+2+tc)
i=i+tc+1
Else
i=i+1
y=y+2
temp(y)="&#"
End If
End If
If y=0 And prev<>"" Then temp(y)=prev & temp(y):prev=""
ElseIf Mid(content,i,1)="&" Then
tc=InStr(i,content,";")-i
y=y+1
If tc>0 Then
td=Mid(content,i+1,tc-1)
tc=checkcode(td,1,1)
If tc>0 And Len(td)=tc Then
i=i+tc+1
temp(y)="&" & td & ";"
ElseIf tc>0 Then
i=i+tc
temp(y)="&" & Left(td,tc) & ";"
Else
temp(y)="&"
End If
Else
td=checkcode(content,1,i+1)
If td>0 Then
temp(y)=Mid(i,content,i+1+tc)
i=i+tc
Else
temp(y)="&"
End If
End If
If y=0 And prev<>"" Then temp(y)=prev & temp(y):prev=""
ElseIf Mid(content,i,2)="</" Then
tc=InStr(i,content,">")-i
If z>-1 Then
If LCase(etags(z))=LCase(Mid(content,i+2,tc-2)) Then
z=z-1
If z>-1 Then
ReDim Preserve tags(z)
ReDim Preserve etags(z)
Else
tags(0)=""
etags(0)=""
End If
temp(y)= temp(y) & Mid(content,i,tc+1)
End If
End If
i=i+tc
ElseIf Mid(content,i,1)="<" Then
If y<0 Then y=0:temp(y)=prev:prev=""
tag=Mid(content,i+1,InStr(i,content,">")-i-1)
If InStr(tag,Chr(32))>0 Then
etag=Trim(Left( tag,InStr(tag,Chr(32)) ))
ElseIf InStr(tag,Chr(9))>0 Then
etag=Trim(Left( tag,InStr(tag,Chr(9)) ))
ElseIf InStr(tag,Chr(10))>0 Then
etag=Trim(Left( tag,InStr(tag,Chr(10)) ))
Else
etag=tag
End If
tc=Len(tag)
Select Case LCase(etag)
Case "img"
ti=ti+1
temp(y)= temp(y) & Mid(content,i,InStr(i,content,">")-i+1)
Case "br","hr","col","embed","input","param"
temp(y)= temp(y) & Mid(content,i,InStr(i,content,">")-i+1)
Case "textarea","select","style","script"
temp(y)= temp(y) & Mid(content,i,InStr(i,LCase(content),"</"& LCase(etag) &">")-i+Len(etag)+2)
Case Else
z=z+1
ReDim Preserve tags(z)
ReDim Preserve etags(z)
tags(z)=tag
etags(z)=etag
temp(y)= temp(y) & "<" & tag & ">"
End Select
i=i+tc+1
Else
y=y+1
If y=0 Then
temp(y)=prev & Mid(content,i,1)
prev=""
Else
temp(y)=Mid(content,i,1)
End If
End If
If (y>=pagesize-lo And Mid(content,i+1,2)<>"</" And Mid(content,i+1,1)="<") Or _
(y>=pagesize+lo And Mid(content,i+1,2)<>"</") Or _
(ti>=picNum And LCase(Mid(content,i+1,4))="<img") Or i=Len(content) Then
x=x+1
ReDim Preserve page(x)
If etags(0)<>"" Then
temp(y)= temp(y) & "</" & Join(Reverse(etags),"></") & ">"
page(x)=Join(temp,"")
prev="<" & Join(tags,"><") & ">"
Else
page(x)=Join(temp,"")
End If
y=-1
ti=0
ReDim temp(pagesize+lo+2)
End If
Next
End Sub
Private Function CheckCode(str,stype,ByVal ps)
CheckCode=0
Dim rstr,i
rstr=""
If stype=1 Then
For i=0 To Ubound(types(1))
If LCase(Mid(str,ps,Len(types(1)(i))))=types(1)(i) Then
CheckCode=Len(types(1)(i))
Exit Function
End If
Next
Else
For i=ps To Len(str)-ps
If InStr(types(stype),Mid(str,i,1))<1 Then
CheckCode=i-1-ps
Exit Function
End If
Next
End If
End Function
Private Sub Class_Terminate
Erase page
Erase temp
Erase tags
Erase etags
Erase types
End Sub
End Class
豫公网安备 41112102000155号