带HTML代码的文章摘要截取 (种实现方法)

1、
function gotTopic(str,strlen)
if str="" then
gotTopic=""
exit function
end if
dim l,t,c, i
str=replace(replace(replace(replace(str,"&nbsp;"," "),"&quot;",chr(34)),"&gt;",">"),"&lt;","<")
l=len(str)
t=0
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
gotTopic=left(str,i) & "…"
exit for
else
gotTopic=str
end if
next
gotTopic=replace(replace(replace(replace(gotTopic," ","&nbsp;"),chr(34),"&quot;"),">","&gt;"),"<","&lt;")
end function




2、
比如储存图片内容是pic,内容content

function showcontent()
if content<>"" then
response.write left(content,50)
elseif pic<>"" and content="" then
response.write "<img>"&"&pic&"&"</img>"
elseif pic="" and content=""then
response.write "无内容"
end if
end function




3、
'*************************************
'切割内容 - 按行分割(行数)
'*************************************
Function SplitLines(byVal Content,byVal ContentNums)
Dim ts,i,l
ContentNums=int(ContentNums)
If IsNull(Content) Then Exit Function
i=1
ts = 0
For i=1 to Len(Content)
l=Lcase(Mid(Content,i,5))
If l="<br/>" Then
ts=ts+1
End If
l=Lcase(Mid(Content,i,4))
If l="<br>" Then
ts=ts+1
End If
l=Lcase(Mid(Content,i,3))
If l="<p>" Then
ts=ts+1
End If
If ts>ContentNums Then Exit For
Next
If ts>ContentNums Then
Content=Left(Content,i-1)
End If
SplitLines=Content
End Function

'*************************************
'切割内容 - 按字符分割（字符）
'*************************************
Function CutStr(byVal Str,byVal StrLen)
Dim l,t,c,i
If IsNull(Str) Then CutStr="":Exit Function
l=Len(str)
StrLen=int(StrLen)
t=0
For i=1 To l
c=Asc(Mid(str,i,1))
If c<0 Or c>255 Then t=t+2 Else t=t+1
IF t>=StrLen Then
CutStr=left(Str,i)&"..."
Exit For
Else
CutStr=Str
End If
Next
End Function





4、
截取文章摘要（无损HTML）
发表于217 天前 ? ASP ? 暂无评论

鲁莽截取：页面变形
以前曾经做过一个班级主页的ASP系统，在首页显示文章时我用了截取措施。但是那只是鲁莽地用left([string],[length])截取了一下，结果经常因为HTML标记不完全而导致页面变形。

str=left(str,500)

除去HTML元素再截取：太过于简陋
后来想到一个很BT的方法，除去文章的所有HTML元素再截取。效果好了很多，从此再没有出现页面变形的事故。这个方法一直被我使用，从新版的班级主页到SuoMBlog到班级信息平台，全是这东西。但是当我看到百度、网易的无损HTML的截取后，突然发觉自己的代码多么丑陋。

str=left(nohtml(str),500)
'除去HTML元素
Function nohtml(str)
dim re
Set re=new RegExp
re.IgnoreCase =true
re.Global=True
re.Pattern="<(.[^>]*)>"
str=re.replace(str,"")
nohtml=str
set re=nothing
End Function

自动补全HTML元素：嗯，不错,完美
其实想法很早就有了，尤其是今年年初受到HTML特性的启发，但是当时的算法太繁琐，而且效率低，自己也没心思去弄。于是就搁置在那里。今天凌晨睡不着，想到后重新构建了算法，并且在脑子里“试运行”了几遍，优化了一下后就把程序敲出来了。觉得也没有想象中的那么难，轻轻松松就解决了。所以，程序员一定不能懒。
在这个算法里，运用了栈，因为HTML元素有始必有终嘛。看看代码就晓得咯。

str=HTMLCutter(str,500)
'无损截取HTML
Function HTMLCutter(str, l)
'声明一个栈，100层够大吧
Dim sFIFO(100)
'一些参数
p = 1
str = Trim(str)
maxlong = Len(str)
'参数
FlagHTML = False
longStr = 0
'开始扫描文章
For i = 1 To maxlong
'提取第i位的字符
c = Mid(str, i, 1)
'判断HTML元素开始
If c = "<" Then
If FlagHTML Then longStr = longStr + i - istart
FlagHTML = True
istart = i
Else
If FlagHTML Then
If c = ">" Then
iend = i
tmpStr = Mid(str, istart + 1, iend - istart - 1)

'检查元素为开始还是结束
'判断是否是的标签
If Right(tmpStr, 1) <> "/" Then
If Left(tmpStr, 1) = "/" Then
'结束标签
If sFIFO(p) = Right(tmpStr, Len(tmpStr) - 1) Then p = p - 1

FlagHTML = False
Else
'开始标签
p = p + 1

t = InStr(1, tmpStr, " ")
If t <> 0 Then tmpStr = Left(tmpStr, t - 1)

sFIFO(p) = tmpStr
End If
End If
End If
Else
longStr = longStr + 1
If longStr >= l Then Exit For
End If
End If
Next

fStr = Left(str, i)
'把没有闭合的HTML元素补上
For j = p To 1 Step -1
If sFIFO(j) <> "" Then endStr = endStr & " Next

HTMLCutter = fStr & endStr
End Function






5、
给你一个我自己总结的一个函数吧，支持中英文混搭的，在文字排版上非常好用的

Function s_len(str1,num_n,sort_d)
'str1为字符串,num_n为要显示的字数,sort_d为结尾的符号如...或~

'str1=RecovertHTML(str1)
str1=replace(str1, "<","<")'还原字符串
str1=replace(str1, ">", ">")
str1=replace(str1,""",chr(34))
str1=replace(str1,"'",chr(39))
'str1=replace(str1, "<br />",vbCrLf)
str1=replace(str1, " "," ")
str1=replace(str1, " "," ")

length=len(str1)
dim chinese,ii
chinese=0
for ii=1 to length

if asc(mid(str1,ii,1))<1 or asc(mid(str1,ii,1))>255 then
chinese=chinese+1
end if
if chinese+ii>num_n then '超过规定的数，就退出循环
exit for
end if
next
s_len=left(str1,ii)
kk=right(s_len,1)
if asc(mid(str1,1,1))<1 or asc(mid(str1,1,1))>255 then '如果算完后最后一个是双字节数，则总数再减一
iii=ii-1
s_len=left(str1,iii)
end if

if chinese+ii>num_n then '如果标题大于规定的字数时后面加...
s_len=s_len+sort_d
end if

s_len=Replace(s_len,"<br />", " ")
s_len=Replace(s_len,"<br>", " ")
s_len=Replace(s_len,"<","<")
s_len=Replace(s_len,">",">")
s_len=Replace(s_len," ", " ")
s_len=Replace(s_len,chr(34),""")
s_len=Replace(s_len,chr(39),"'")
s_len=Replace(s_len,vbCrLf,"<br />")

'response.write "字符串:" & str1 & "<br>"
'response.write "s_len(command)=" & s_len & "<br>"
'response.write "length+chinese字数为:" & length+chinese & "<br>"
'response.write "chinese+ii=" & chinese+ii & "<br>"
'response.write "ii=" & ii & "<br>"
'response.write "其中中文" & chinese & "个，非中文" & length-chinese & "个<br>"
End Function