|
|
kmx1001
发表于 2011-9-29 16:57:23
|
显示全部楼层
贴出这个代码 望版主看看
<%
response.Buffer=true
Function isInt(str)
Dim L,I
isInt=False
If Trim(Str)="" Or IsNull(str) Then Exit Function
str=CStr(Trim(str))
L=Len(Str)
For I=1 To L
If Mid(Str,I,1)>"9" Or Mid(Str,I,1)<"0" Then Exit Function
Next
isInt=True
End Function
Function CheckStr(Str)
If Trim(Str)="" Or IsNull(str) Then Exit Function
Checkstr=Replace(Trim(Str),"'","''")
End Function
Function HtmlEncode(str)
If Trim(Str)="" Or IsNull(str) Then Exit Function
str=Replace(str,">",">")
str=Replace(str,"<","<")
str=Replace(str,Chr(32)," ")
str=Replace(str,Chr(9)," ")
str=Replace(str,Chr(34),""")
str=Replace(str,Chr(39),"'")
str=Replace(str,Chr(13),"")
str=Replace(str,Chr(10) & Chr(10), "</p><p>")
str=Replace(str,Chr(10),"<br> ")
HtmlEncode=str
End Function
Function CheckWord(Str)
Dim SplitWord,i
If trim(Str)="" Then Exit Function
Splitword=Split(SplitWords,",")
For I=0 To Ubound(Splitword)
Str=Replace(Str, Splitword(I),String(Len(Splitword(I)),"*"))
Next
Checkword=Str
End Function
Function strLen(Str)
If Trim(Str)="" Or IsNull(str) Then Exit Function
Dim P_len,x
P_len=0
StrLen=0
P_len=Len(Trim(Str))
For x=1 To P_len
If Asc(Mid(Str,x,1))<0 Then
StrLen=Int(StrLen) + 2
Else
StrLen=Int(StrLen) + 1
End If
Next
End Function
Function CutStr(Str,LenNum)
Dim P_num
Dim I,X
If StrLen(Str)<=LenNum Then
Cutstr=Str
Else
P_num=0
X=0
Do While Not P_num > LenNum-2
X=X+1
If Asc(Mid(Str,X,1))<0 Then
P_num=Int(P_num) + 2
Else
P_num=Int(P_num) + 1
End If
Cutstr=Left(Trim(Str),X)&"..."
Loop
End If
End Function
Function CataLog(intClassID,intNClassID)
Dim Result,i
Dim a
a=1
If a=1 Then
Result="<script language=""JavaScript"">"&vbcrlf
SQL="SELECT ID,NClass,ParentID FROM NClass ORDER BY Orders"
Result=Result&"var nclassid="&intNClassID&";"
Set Rs=Server.CreateObject("ADODB.RecordSet")
Rs.Open SQL,Conn,1
If Not (Rs.EOF Or Rs.BOF) Then
i=-1
Do Until Rs.EOF
i=i+1
Result=Result&"arrNList["&i&"] = """&Rs(2)&""""&vbcrlf
i=i+1
Result=Result&"arrNList["&i&"] = """&Rs(1)&""""&vbcrlf
i=i+1
Result=Result&"arrNList["&i&"] = """&Rs(0)&""""&vbcrlf
Rs.MoveNext
Loop
End If
Set Rs=Nothing
Result=Result&"</script>"
End If
Result=Result&"<select onChange=""Kermy_JS('setDynaList(arrNSet)')"" name=""ClassID"" id=""ClassID"">"&vbcrlf
SQL="SELECT ID,Class FROM Class ORDER BY Orders"
Set Rs=Conn.Execute(SQL)
If Not (Rs.EOF Or Rs.BOF) Then
Do Until Rs.EOF
If intClassID=Rs(0) Then
Result=Result&"<option value="&Rs(0)&" selected>"&Rs(1)&"</option>"&vbcrlf
Else
Result=Result&"<option value="&Rs(0)&">"&Rs(1)&"</option>"&vbcrlf
End If
Rs.MoveNext
Loop
Else
Result=Result&"<option value=0>尚未添加一级分类</option>"
End If
Set Rs=Nothing
Result=Result&"</select>"&vbcrlf
Result=Result&"<select name=""NClassID"" id=""NClassID""></select>"
CataLog=Result
End Function
Function Special(sid)
Dim Result
Result=Result&"<select name=""SpecialID"" id=""SpecialID"">"&vbcrlf
SQL="SELECT ID,Name FROM Special ORDER BY ID"
Set Rs=Conn.Execute(SQL)
If Not (Rs.EOF Or Rs.BOF) Then
Result=Result&"<option value=0 selected>不属于任何专题</option>"&vbcrlf
Do Until Rs.EOF
If CInt(sid)=Rs(0) Then
Result=Result&"<option value="&Rs(0)&" selected>"&Rs(1)&"</option>"&vbcrlf
Else
Result=Result&"<option value="&Rs(0)&">"&Rs(1)&"</option>"&vbcrlf
End If
Rs.MoveNext
Loop
Else
Result=Result&"<option value=0 selected>尚未添加专题</option>"&vbcrlf
End If
Set Rs=Nothing
Result=Result&"</select>"&vbcrlf
Special=Result
End Function
Function ShowPage(ByRef PageCount,RecordCount,CurrentPage,PageSize,LinkFile)
Dim Retval,J,StartPage,EndPage
If (RecordCount Mod PageSize)=0 Then
PageCount=RecordCount \ PageSize
Else
PageCount=RecordCount \ PageSize+1
End If
If PageCount=0 Then PageCount=1
If CurrentPage="" Then CurrentPage=1 else CurrentPage=CInt(CurrentPage)
Retval=Retval & "<table width='100%' border='0' cellspacing='0' cellpadding='0'>"
Retval=Retval & "<tr>"
Retval=Retval & "<td height='20'>"
If CurrentPage=1 Then
Retval=Retval & "<font style='color:#999999'>首页</font> | <font style='color:#999999'>前页</font> | "
Else
Retval=Retval & "<a href='" & LinkFile & "Page=1'>首页</a> | <a href='" & LinkFile & "Page=" & CurrentPage - 1 & "'>前页</a> | "
End If
If CurrentPage=PageCount Then
Retval=Retval & "<font style='color:#999999'>后页</font> | <font style='color:#999999'>末页</font>"
Else
Retval=Retval & "<a href='" & LinkFile & "Page=" & CurrentPage + 1 & "'>后页</a> | <a href='" & LinkFile & "Page=" & PageCount & "'>末页</a>"
End if
If RecordCount>0 Then
Retval=Retval & " | <b>"&CurrentPage&"</b>页/<b>"&CInt(PageCount)&"</b>页 | 共<b>"&RecordCount&"</b>条记录"
End If
Retval=Retval & "<td align='right'>"
StartPage = Page-3
EndPage = Page+3
If StartPage<=0 Then
StartPage=1
ElseIf StartPage>1 Then
Retval=Retval & " <a href='" & LinkFile & "Page=1' style='font-family:webdings' title='首页'>9</a>"
Retval=Retval & " ... "
End If
If EndPage>PageCount Then EndPage=PageCount
For J = StartPage to EndPage
If J = Page Then
Retval = Retval & " <font color=#999999>" & J & "</font>"
Else
Retval = Retval & " <a href='" & LinkFile & "Page=" & J & "'>" & J & "</a>"
End If
Next
If EndPage < PageCount Then Retval= Retval & " ... <a href='" & LinkFile & "Page=" & PageCount & "' style='font-family:webdings' title='末页'>:</a>"
Retval=Retval & "</td>"
Retval=Retval & "</tr>"
Retval=Retval & "</table>"
ShowPage=Retval
End Function
Function LoadTemplate(str)
If Application("Art_T_"&DefaultTemplate&str)="" Then
If str="" Or IsNull(str) Then Exit Function
Dim objStream,Template_Dir,Template_File
If IsNull(DefaultTemplate) Or DefaultTemplate="" Then DefaultTemplate=Site_Info(7)
Template_Dir="Template/"&DefaultTemplate
Template_File=Article_Url&Template_Dir&str&".htm"
On Error Resume Next
Set objStream = Server.CreateObject("ADODB.Stream")
If Err.Number=-2147221005 Then
Response.Write "<div align='center'>非常遗憾,您的主机不支持ADODB.Stream,不能使用本程序</div>"
Err.Clear
Response.End
End If
With objStream
.Type = 2
.Mode = 3
.Open
.LoadFromFile Server.MapPath(Template_File)
If Err.Number<>0 Then
Response.Write "你没有权限"
Err.Clear
Response.End
End If
.Charset = "GB2312"
.Position = 2
LoadTemplate = .ReadText
.Close
End With
Set objStream = Nothing
Application("Art_T_"&DefaultTemplate&str)=LoadTemplate
Else
LoadTemplate=Application("Art_T_"&DefaultTemplate&str)
End If
End Function
Function Index_List()
Dim index_list_bottom,newartloop,Title,TitleColor,ClassID,ID
Dim arrClass,arrArticle,cRows,aRows,N
Dim RsImage
If CInt(Site_Info(16))=0 Then
SqlStr=""
Else
SqlStr="Top "&Site_Info(16)
End If
SQL="Select "&SqlStr&" ID,Class From Class Order By Orders"
Set Rs=Conn.Execute(SQL)
If Not Rs.EOF Then
arrClass=Rs.GetRows()
cRows=UBound(arrClass,2)
Set Rs=Nothing
For i=0 to cRows
ClassID=arrClass(0,i)
SQL="Select Top 7 ID,Title,AddDate,TitleColor From Article Where ClassID="&ClassID&" Order By ID Desc"
Set Rs=Conn.Execute(SQL)
If Not (Rs.EOF Or Rs.BOF) Then
arrArticle=Rs.GetRows()
aRows=UBound(arrArticle,2)
Set Rs=Nothing
For N=0 to aRows
newartloop=newartloop&LoadTemplate("index_main_loop")
Title=CutStr(arrArticle(1,n),40)
TitleColor=arrArticle(3,n)
ID=arrArticle(0,n)
If TitleColor<>"" Then Title="<font style='color:"&TitleColor&";'>"&Title&"</font>"
newartloop=Replace(newartloop,"{id}",ID)
newartloop=Replace(newartloop,"{title}",Title)
newartloop=Replace(newartloop,"{adddate}",FormatDateTime(arrArticle(2,n),2))
Next
End If
'首页左图片
index_list_bottom=LoadTemplate("index_main_bottom")
SQL="Select Top 1 ID,Title,TitleColor,Previewimg From Article Where isPic=1 And ClassID="&ClassID&" Order By ID Desc"
Set RsImage=Conn.Execute(SQL)
If Not (RsImage.EOF Or RsImage.BOF) Then
Title=CutStr(RsImage(1),40)
TitleColor=RsImage(2)
If TitleColor<>"" Then Title="<font style='color:"&TitleColor&";'>"&Title&"</font>"
index_list_bottom=Replace(index_list_bottom,"{title}",Title)
index_list_bottom=Replace(index_list_bottom,"{previewimg}","<a href='dispArticle.Asp?ID="&RsImage(0)&"' title="""&Title&"""><img src='"&RsImage(3)&"' width='120' height='90' border='0'></a>")
Else
index_list_bottom=Replace(index_list_bottom,"{previewimg}","")
index_list_bottom=Replace(index_list_bottom,"{title}","")
End If
index_list=index_list&LoadTemplate("index_main_top")&index_list_bottom
index_list=Replace(index_list,"{class}",arrClass(1,i))
index_list=Replace(index_list,"{classid}",ClassID)
index_list=Replace(index_list,"{index_newarticle}",newartloop)
newartloop=Empty
Next
End If
Set RsImage=Nothing
End Function
Function IndexTopImage()
'------图片文章循环部分
Dim imgart_loop,Title,TitleColor
imgart_loop=Empty
SQL="Select Top 3 ID,Title,Previewimg,TitleColor From Article Where isIndexPic=1 Order By ID Desc"
Set Rs=Conn.Execute(SQL)
If Rs.EOF Or Rs.BOF Then
imgart_loop=LoadTemplate("index_topimages_nodata")
Else
Do Until Rs.EOF
Title=CutStr(Rs(1),26)
TitleColor=Rs(3)
If TitleColor<>"" Then Title="<font style='color:"&TitleColor&";'>"&Title&"</font>"
imgart_loop=imgart_loop&LoadTemplate("index_topimages_loop")
imgart_loop=Replace(imgart_loop,"{id}",Rs(0))
imgart_loop=Replace(imgart_loop,"{title}",Title)
imgart_loop=Replace(imgart_loop,"{previewimg}",Rs(2))
Rs.MoveNext
Loop
End If
Set Rs=Nothing
IndexTopImage=imgart_loop
End Function
'//广告随机显示
Function AdRotator(strAd,adSplit)
Dim i
strAd=Split(strAd,adSplit)
Randomize
I=cint(ubound(strAd)*rnd)
On Error Resume Next
If Err>0 Then Exit Function
AdRotator=strAd(i)
End Function
Sub GetSetting()
Dim objXML,objRoot,Total,I
Set objXML=Server.CreateObject("Microsoft.XMLDOM")
objXML.async=False
objXML.load (Server.Mappath(SettingFile))
Set objRoot=objXML.selectsinglenode("系统设置/系统设置")
Total=objRoot.childnodes.length
ReDim Site_Info(Total-1)
For I=0 To Total-1
Site_info(i)=objRoot.childnodes(i).text
'Response.Write "site_info("&i&")"&site_info(i)&"<br>"
Next
Set objRoot=Nothing
Set objXML=Nothing
End Sub
Sub DataClose()
If IsObject(Conn) Then
Conn.Close
Set Conn=Nothing
End If
End Sub
Sub Foot()
DataClose()
Response.Write "<Div Align=Center>页面执行时间:"&Fix(Formatnumber((Timer-StartTime)*1000,3))&" ms</Div>"
End Sub
'// 错误信息
Sub Msg()
If InStr(ScriptName,"admin")<>0 Then
Html=LoadTemplate("admin/msg")
Else
Html=LoadTemplate("msg")
End If
ReplaceFoot()
Response.Write Replace(Html,"{strerr}",strMsg)
Response.End
End Sub
Sub ReplaceFoot()
Html=Replace(Html,"{copyright}",CopyRight)
Html=Replace(Html,"{poweredby}",Version)
End Sub
%> |
|
GoDaddy
1283 人阅读
|
6 人回复
狗仔卡
提升卡
置顶卡
沉默卡
喧嚣卡
变色卡
显身卡
