📄 act.main.asp
字号:
End If
If ShowAllPages = True Then
PageStr = PageStr & ("GO:<select onChange='location.href=this.value;' style='width:55;' name='select'>")
For I = 1 To N
If Cint(CurrentPage) = I Then
PageStr = PageStr & ("<option value=" & FileName & "?page=" & I & "&" & ParamterStr & " selected>NO." & I & "</option>")
Else
PageStr = PageStr & ("<option value=" & FileName & "?page=" & I & "&" & ParamterStr & ">NO." & I & "</option>")
End If
Next
PageStr = PageStr & "</select>"
End If
End If
ShowPagePara = PageStr
End Function
Public Function ChkNumeric(ByVal CheckID)
If CheckID <> "" And IsNumeric(CheckID) Then
CheckID = CLng(CheckID)
If CheckID < 0 Then CheckID = 0
Else
CheckID = 0
End If
ChkNumeric = CheckID
End Function
'过滤非法的SQL字符
Public Function RSQL(strChar)
If strChar = "" Or IsNull(strChar) Then RSQL = "":Exit Function
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
RSQL = tempChar
End Function
Public Function GetIP()
Dim strIPAddr
If Request.ServerVariables("HTTP_X_FORWARDED_FOR") = "" Or InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), "unknown") > 0 Then
strIPAddr = Request.ServerVariables("REMOTE_ADDR")
ElseIf InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ",") > 0 Then
strIPAddr = Mid(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), 1, InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ",")-1)
ElseIf InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ";") > 0 Then
strIPAddr = Mid(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), 1, InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ";")-1)
Else
strIPAddr = Request.ServerVariables("HTTP_X_FORWARDED_FOR")
End If
getIP = Replace(Trim(Mid(strIPAddr, 1, 30)), "'", "")
getIP = Replace(getIP,";","")
getIP = Replace(getIP,"-","")
getIP = Replace(getIP,"(","")
getIP = Replace(getIP,")","")
getIP = Replace(getIP,">","")
getIP = Replace(getIP,"<","")
getIP = Replace(getIP,"=","")
getIP = Replace(getIP,"*","")
End Function
Function GainClassName(ClassID,opens,TitleCssName)
on error resume next
Dim ClassRSArr
ClassID=Trim(Replace(ClassID,"'",""))
Name = CStr("Navigation" & ClassID&opens&TitleCssName)
If ObjIsEmpty() Then
Dim ClassRS,ClassPurview
Set ClassRS = ActExe("Select Classename,Extension,GroupIDClass,ModeID,ClassID,ClassName,ChangesLinkUrl From Class_ACT Where classID='" & ClassID & "'")
Value = ClassRS.GetRows(1):Set ClassRS = Nothing
End If
ClassRSArr = Value
IF ClassRSArr(6,0)<>"" Then
GainClassName= "<a " & TitleCssName & " href=""" & ClassRSArr(6,0) & """" & opens & ">"& ClassRSArr(5,0) & "</a>"
Else
IF ClassRSArr(2,0)<>"" Or ACT_C(ClassRSArr(3,0),3)=0 Then
GainClassName= "<a " & TitleCssName & " href=""" & ActCMSDM & "Article/TypeClass.asp?ClassID="& ClassRSArr(4,0) & """" & opens & ">"& ClassRSArr(5,0) & "</a>"
Else
GainClassName= "<a " & TitleCssName & " href=""" & ActCMSDM&ACT_C(ClassRSArr(3,0),6)&ClassRSArr(0,0)& """" & opens & ">"& ClassRSArr(5,0) & "</a>"
End If
End If
End Function
Function MoreName(ClassID)
Dim ClassRSArr
Name = CStr("More" & ClassID)
ClassID=Trim(Replace(ClassID,"'",""))
If ObjIsEmpty() Then
Dim ClassRS,ClassPurview
Set ClassRS = ActExe("Select Classename,Extension,GroupIDClass,ModeID,ClassID,ClassName From Class_ACT Where classID='" & ClassID & "'")
Value = ClassRS.GetRows(1):ClassRS.Close:Set ClassRS = Nothing
End IF
ClassRSArr = Value
IF ClassRSArr(2,0)<>"" Or ACT_C(ClassRSArr(3,0),3)=0 Then
MoreName= ActCMSDM & "Article/TypeClass.asp?ClassID="& ClassRSArr(4,0)
Else
MoreName= ActCMSDM&ACT_C(ClassRSArr(3,0),6)&ClassRSArr(0,0)
End If
End Function
Public Function ReturnChannelUpFilesDir(ModeID)
Dim InstallDir
If ModeID = "" Or Not IsNumeric(ModeID) Then ModeID = 0
Dim CRS:Set CRS=server.CreateObject("adodb.recordset")
CRS.Open "Select UpFilesDir From Mode_Act Where ModeID=" & ModeID, Conn, 1, 1
If CInt(ModeID) = 0 Or (CRS.EOF And CRS.BOF) Then
ReturnChannelUpFilesDir = "UpFilesDir/"
Else
ReturnChannelUpFilesDir = CRS(0)
End If
ReturnChannelUpFilesDir = Left(ReturnChannelUpFilesDir, Len(ReturnChannelUpFilesDir) - 1)
If InstallDir = "/" Then ReturnChannelUpFilesDir = "/" & ReturnChannelUpFilesDir
CRS.Close:Set CRS = Nothing
End Function
Sub AddTags(ModeID,Keyword)
Dim i,Tag,TagRs
Set TagRs = Server.createobject("Adodb.Recordset")
Tag = Split(Keyword,",")
For I = 0 To UBound(Tag)
TagRs.Open "Select * From Tags_ACT Where TagsChar ='" & Left(Tag(I),50) & "' And ModeID =" & ModeID,Conn,1,3
If TagRs.Eof Then
TagRs.AddNew
TagRs("TagsChar") = Left(Tag(I),50)
TagRs("ModeID") = ModeID
TagRs("AddTime") = Now
TagRs.Update
End If:TagRs.Close
Next
Set TagRs = Nothing
End Sub
Function AutoSplitPage(StrNewsContent,Page_Split_page,AutoPagesNum)'自动分页
Dim i,IsCount,OneChar,StrCount,FoundStr,Pages_i_Str,Pages_i_Arr
AutoPagesNum = Clng(AutoPagesNum)
Page_Split_page = Cstr(Page_Split_page)
If Len(StrNewsContent) < Int(AutoPagesNum+Round(AutoPagesNum/5)) Then AutoSplitPage=StrNewsContent : Exit Function
If StrNewsContent<>"" and AutoPagesNum<>0 and InStr(1,StrNewsContent,Page_Split_page)=0 then
IsCount=True
Pages_i_Str=""
For i= 1 To Len(StrNewsContent)
OneChar=Mid(StrNewsContent,i,1)
If OneChar="<" Then
IsCount=False
ElseIf OneChar=">" Then
IsCount=True
Else
If IsCount=True Then
If Abs(Asc(OneChar))>255 Then
StrCount=StrCount+2
Else
StrCount=StrCount+1
End If
If StrCount>=AutoPagesNum And i<Len(StrNewsContent) Then
FoundStr=Left(StrNewsContent,i)
If AllowSplitPage(FoundStr,"table|a|b>|i>|strong|div|span")=true then
Pages_i_Str=Pages_i_Str & Trim(CStr(i)) & ","
StrCount=0
End If
End If
End If
End If
Next
If Len(Pages_i_Str)>1 Then Pages_i_Str=Left(Pages_i_Str,Len(Pages_i_Str)-1)
Pages_i_Arr=Split(Pages_i_Str,",")
For i = UBound(Pages_i_Arr) To LBound(Pages_i_Arr) Step -1
StrNewsContent=Left(StrNewsContent,Pages_i_Arr(i)) & Page_Split_page & Mid(StrNewsContent,Pages_i_Arr(i)+1)
Next
End If
AutoSplitPage=StrNewsContent
End Function
Function AllowSplitPage(TempStr,FindStr)
Dim Inti,BeginStr,EndStr,BeginStrNum,EndStrNum,ArrStrFind,i
TempStr=LCase(TempStr)
FindStr=LCase(FindStr)
If TempStr<>"" and FindStr<>"" then
ArrStrFind=split(FindStr,"|")
For i = 0 to Ubound(ArrStrFind)
BeginStr="<"&ArrStrFind(i)
EndStr ="</"&ArrStrFind(i)
Inti=0
do while instr(Inti+1,TempStr,BeginStr)<>0
Inti=instr(Inti+1,TempStr,BeginStr)
BeginStrNum=BeginStrNum+1
Loop
Inti=0
do while instr(Inti+1,TempStr,EndStr)<>0
Inti=instr(Inti+1,TempStr,EndStr)
EndStrNum=EndStrNum+1
Loop
If EndStrNum=BeginStrNum then
AllowSplitPage=true
Else
AllowSplitPage=False
Exit Function
End If
Next
Else
AllowSplitPage=False
End If
End Function
'取得每篇文章、图片链接
Public Function GetInfoUrl(ByVal ModeID,ByVal ClassID,ByVal ID,ByVal ChangesLink,ByVal FileName,ByVal GroupID_ACT,ByVal Score_ACT)
IF Not Isnumeric(ModeID) Then GetInfoUrl="#":Exit Function
If ChangesLink = 1 Then
GetInfoUrl = FileName
ElseIf Score_ACT>0 Or ACT_C(ModeID,3)=0 Or GroupID_ACT<>"" Or ACT_L(ClassID,6)<>"" Then '动态
GetInfoUrl= ActCMSDM&"Article/TypeArticle.asp?ModeID="&ModeID&"&ID=" &ID
Else
Dim Tmps,TmpUs
If Right(ACT_C(ModeID,10),1)<>"/" Then
GetInfoUrl= ActCMSDM&ACT_C(ModeID,6)&FileName&ACT_C(ModeID,11)
Else
GetInfoUrl= ActCMSDM&ACT_C(ModeID,6)&FileName&"/"
End If
End If
End Function
'显示分页的前部分
'参数说明:PageStyle-分页样式,ItemUnit-单位,TotalPage-总页数,CurrPage-当前第N页,TotalInfo-总信息数,PerPageNumber-每页显示数
Function GetPageList(PageStyle,ItemUnit,TotalPage,CurrPage,TotalInfo,PerPageNumber)
Select Case Cint(PageStyle)
Case 1
GetPageList= "<div class=""pages""><div class=""plist"">" & "共 " & TotalInfo & " " & ItemUnit &" 页次:<font color=red> " & CurrPage & "</font>/" & TotalPage & "页 " & PerPageNumber & " " & ItemUnit &"/页 "
Case 2
GetPageList= "<div class=""pages""><div class=""plist"">第<font color=red>" & CurrPage & "</font>页 共" & TotalPage & "页 "
Case 3
GetPageList= "<div class=""pages""><div class=""plist"">第<font color=red>" & CurrPage & "</font>页 共" & TotalPage & "页 "
End Select
End Function
Public Function ReturnPageStyle(PageStyle)
ReturnPageStyle = " 分页样式"
ReturnPageStyle = ReturnPageStyle & " <select name=""PageStyle"" style=""width:70%;"" class=""textbox"">"
ReturnPageStyle = ReturnPageStyle & " <option value=1"
If PageStyle=1 Then ReturnPageStyle = ReturnPageStyle & " Selected"
ReturnPageStyle = ReturnPageStyle & ">①首页 上一页 下一页 尾页</option>"
ReturnPageStyle = ReturnPageStyle & " <option value=2"
If PageStyle=2 Then ReturnPageStyle = ReturnPageStyle & " Selected"
ReturnPageStyle = ReturnPageStyle & ">②第N页,共N页 [1] [2] [3]</option>"
ReturnPageStyle = ReturnPageStyle & " <option value=3"
If PageStyle=3 Then ReturnPageStyle = ReturnPageStyle & " Selected"
ReturnPageStyle = ReturnPageStyle & ">③<< < > >></option>"
ReturnPageStyle = ReturnPageStyle & " </select>"
End Function
Public Function GetEn(EnStr)
Dim EnStr4,EnStr3,EnStr2,EnStr1
Set EnStr1=new regexp
EnStr1.ignorecase=true
EnStr1.global=true
EnStr1.pattern="[a-zA-Z0-9\- ]"
Set EnStr3=EnStr1.execute(EnStr)
For each EnStr2 in EnStr3
EnStr4=EnStr4&EnStr2.value
Next
Set EnStr3= Nothing
Set EnStr1=nothing
EnStr4=trim(EnStr4)
If len(EnStr4)>0 then EnStr4=replace(EnStr4," ","-")
While (instr(EnStr4,"--")>0)
EnStr4=replace(EnStr4,"--","-")
Wend
GetEn =EnStr4
End Function
Public Function PinYin(StrChar)
Dim StrLens,RsStr,StrLen,StrTitle,IFCN,i,Rs
On Error Resume Next
Set RsStr=Server.Createobject("Adodb.Connection")
RsStr.open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source="& Server.MapPath(ActCMS_Sys(3)&"ACT_inc/pinyin.asp")
IFCN=true
For i=1 to len(StrChar)
StrTitle=IFCN
StrLen=mid(StrChar,i,1)
If len(trim(StrLen)) = 1 Then
set rs=RsStr.execute("select top 1 pinyin from pinyin where content like '%"&StrLen&"%';")
if not rs.eof and not rs.bof Then
StrLen=rs(0)
IFCN=True
Else
IFCN=False
End If
Rs.Close:Set Rs = Nothing
Else
StrLen=" "
End If
If StrTitle=IFCN Then
StrLens=StrLens&StrLen
Else
StrLens=StrLens&" "&StrLen
End If
Next
RsStr.Close:Set RsStr=nothing
PinYin=Trim(StrLens)
End Function
Public Function GetGroup_CheckBox(OptionName,SelectArr,RowNum)
On Error Resume Next
Dim n:n=0
Dim RSGroup,GroupName:Set RSGroup=Server.CreateObject("Adodb.Recordset")
IF RowNum<=0 Then RowNum=3
RSGroup.Open "Select GroupID,GroupSetting From Group_ACT",Conn,1,1
GetGroup_CheckBox="<table width=""100%"" align=""center"" border=""0"">"
Do While Not RSGroup.Eof
GetGroup_CheckBox=GetGroup_CheckBox & "<TR>"
For N=1 To RowNum
GroupName=Split(RSGroup(1),"^@$@^")(0)
GetGroup_CheckBox=GetGroup_CheckBox & "<TD WIDTH=""" & CInt(100 / CInt(RowNum)) & "%"">"
If Instr(SelectArr,RSGroup(0))<>0 Then
GetGroup_CheckBox=GetGroup_CheckBox & "<input id="& OptionName&RSGroup(0)&" type=""checkbox"" checked name=""" & OptionName & """ value=""" & RSGroup(0) & """><label for="& OptionName&RSGroup(0) &">" & GroupName & "</label> "
Else
GetGroup_CheckBox=GetGroup_CheckBox & "<input id="& OptionName&RSGroup(0)&" type=""checkbox"" name=""" & OptionName & """ value=""" & RSGroup(0) & """><label for="& OptionName&RSGroup(0) &">" & GroupName & "</label> "
End IF
GetGroup_CheckBox=GetGroup_CheckBox & "</TD>"
RSGroup.MoveNext
If RSGroup.Eof Then Exit For
Next
GetGroup_CheckBox=GetGroup_CheckBox & "</TR>"
If RSGroup.Eof Then Exit Do
Loop
GetGroup_CheckBox=GetGroup_CheckBox & "</TABLE>"
RSGroup.Close:Set RSGroup=Nothing
End Function
'****************************************************
'参数说明
'Subject : 邮件标题
'MailAddress : 发件服务器的地址,如smtp.163.com
'LoginName ----登录用户名(不需要请填写"")
'LoginPass ----用户密码(不需要请填写"")
'Email : 收件人邮件地址
'Sender : 发件人姓名
'Content : 邮件内容
'Fromer : 发件人的邮件地址
'****************************************************
Public Function SendMail(MailAddress, LoginName, LoginPass, Subject, Email, Sender, Content, Fromer)
on error resume next
Dim JMail
Set jmail = Server.CreateObject("JMAIL.Message") '建立发送邮件的对象
jmail.silent = true '屏蔽例外错误，返回FALSE跟TRUE两值j
jmail.Charset = "gb2312" '邮件的文字编码为国标
jmail.ContentType = "text/html" '邮件的格式为HTML格式
jmail.AddRecipient Email '邮件收件人的地址
jmail.From = Fromer '发件人的E-MAIL地址
jmail.FromName = Sender
If LoginName <> "" And LoginPass <> "" Then
JMail.MailServerUserName = LoginName '您的邮件服务器登录名
JMail.MailServerPassword = LoginPass '登录密码
End If
jmail.Subject = Subject '邮件的标题
JMail.Body = Content
JMail.Priority = 1'邮件的紧急程序，1 为最快，5 为最慢， 3 为默认值
jmail.Send(MailAddress) '执行邮件发送（通过邮件服务器地址）
jmail.Close() '关闭对象
Set JMail = Nothing
If Err Then
SendMail = Err.Description
Err.Clear
Else
SendMail = "OK"
End If
End Function
Public Function IsObjInstalled(strClassString)
on error resume next
IsObjInstalled = False
Err = 0
Dim xTestObj:Set xTestObj = Server.CreateObject(strClassString)
If 0 = Err Then IsObjInstalled = True
Set xTestObj = Nothing
Err = 0
End Function
Public Function IsExpired(strClassString)
on error resume next
IsExpired = True
Err = 0
Dim xTestObj:Set xTestObj = Server.CreateObject(strClassString)
If 0 = Err Then
Select Case strClassString
Case "Persits.Jpeg"
If xTestObjResponse.Expires > Now Then
IsExpired = False
End If
Case "wsImage.Resize"
If InStr(xTestObj.errorinfo, "已经过期") = 0 Then
IsExpired = False
End If
Case "SoftArtisans.ImageGen"
xTestObj.CreateImage 500, 500, RGB(255, 255, 255)
If Err = 0 Then
IsExpired = False
End If
End Select
End If
Set xTestObj = Nothing
Err = 0
End Function
Public Function ExpiredStr(I)
Dim ComponentName(3)
ComponentName(0) = "Persits.Jpeg"
ComponentName(1) = "wsImage.Resize"
ComponentName(2) = "SoftArtisans.ImageGen"
ComponentName(3) = "CreatePreviewImage.cGvbox"
If IsObjInstalled(ComponentName(I)) Then
If IsExpired(ComponentName(I)) Then
ExpiredStr = "，但已过期"
Else
ExpiredStr = ""
End If
ExpiredStr = " √支持" & ExpiredStr
Else
ExpiredStr = "×不支持"
End If
End Function
End Class
%>⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -