📄 function.asp
字号:
elseif DateRightStr = "Center" then
GetRowSpanNumber = "colspan=""" & RowNumberStr * 2 & """"
elseif DateRightStr = "Right" then
GetRowSpanNumber = "colspan=""" & RowNumberStr * 2 & """"
else
GetRowSpanNumber = "colspan=""" & RowNumberStr & """"
end if
else
GetRowSpanNumber = "colspan=""" & RowNumberStr & """"
end if
End Function
Function GetNewsNavitionStr(TxtNaviStr,NaviPicStr)
if TxtNaviStr <> "" then
GetNewsNavitionStr = TxtNaviStr
else
if NaviPicStr <> "" and instr(1,NaviPicStr,"<img")=0 then
GetNewsNavitionStr = "<img src=""" & GetConfig(0) & NaviPicStr & """>"
else
GetNewsNavitionStr = NaviPicStr
end if
end if
End Function
Function GetOpenTypeStr(OpenTypeStr)
if OpenTypeStr = "1" then
GetOpenTypeStr = " target=""_blank"""
else
GetOpenTypeStr = " "
end if
End Function
Function GetTitleNumberStr(TitleNumber)
If TitleNumber <> "" then
GetTitleNumberStr = Cint(TitleNumber)
Else
GetTitleNumberStr = 10
End If
End Function
Function GetCompatPicStr(CompatPicStr,DateRightStr,DateRuleStr,RowNumberStr)
if CompatPicStr <> "" and instr(1,CompatPicStr,"<td Height=1 background")=0 then
if DateRightStr <> "" then
CompatPicStr = "<tr>" & Chr(13) & Chr(10) & "<td Height=1 " & GetRowSpanNumber(DateRuleStr,DateRightStr,RowNumberStr) & ">" & Chr(13) & Chr(10) & "<table width=""100%"" cellpadding=""0"" cellspacing=""0"">" & Chr(13) & Chr(10) & "<tr>" & Chr(13) & Chr(10) & "<td Height=1 background=""" & GetConfig(0) & CompatPicStr & """>" & Chr(13) & Chr(10) & "</td>" & Chr(13) & Chr(10) & "</tr>" & Chr(13) & Chr(10) & "</table>" & Chr(13) & Chr(10) & "</td>" & Chr(13) & Chr(10) & "</tr>"
else
CompatPicStr = "<tr>" & Chr(13) & Chr(10) & "<td Height=1 " & GetRowSpanNumber(DateRuleStr,DateRightStr,RowNumberStr) & ">" & Chr(13) & Chr(10) & "<table width=""100%"" cellpadding=""0"" cellspacing=""0"">" & Chr(13) & Chr(10) & "<tr>" & Chr(13) & Chr(10) & "<td Height=1 background=""" & GetConfig(0) & CompatPicStr & """>" & Chr(13) & Chr(10) & "</td>" & Chr(13) & Chr(10) & "</tr>" & Chr(13) & Chr(10) & "</table>" & Chr(13) & Chr(10) & "</td>" & Chr(13) & Chr(10) & "</tr>"
end if
end if
GetCompatPicStr = CompatPicStr
End Function
Function GetCSSStyleStr(CSSStyleStr)
if CSSStyleStr <> "" then
GetCSSStyleStr = " Class=""" & CSSStyleStr & """"
else
GetCSSStyleStr = ""
end if
End Function
Function GetRecordSearchForm()
Dim i
GetRecordSearchForm = GetRecordSearchForm & "<table width=""100%;"" border=""0""><tr>"
GetRecordSearchForm = GetRecordSearchForm & "<form target=""_blank"" method=""POST"" action=""" & GetConfig(0) & "/RecordSearch.asp" & """ name=""Record_Search_Form""><td>"
GetRecordSearchForm = GetRecordSearchForm & " <select name=""SearchYear"" size=""1""><option value="""" selected> 选择年份 </option>"
For i = 1996 To 2020
GetRecordSearchForm=GetRecordSearchForm & "<option value="""&Trim(CStr(i))&""">" & Trim(CStr(i))& "</option>" & vbcrlf
Next
GetRecordSearchForm = GetRecordSearchForm & "</select> <select name=""SearchMonth"" size=""1""><option value="""" selected> 选择月份 </option>"
For i= 1 To 12
GetRecordSearchForm=GetRecordSearchForm & "<option value="""&Right("0" & Trim(CStr(i)),2)&""">" & Trim(CStr(i))& "</option>" & vbcrlf
Next
GetRecordSearchForm = GetRecordSearchForm & "</select> <select name=""SearchDate"" size=""1""><option value="""" selected> 选择日期 </option>"
For i= 1 To 31
GetRecordSearchForm=GetRecordSearchForm & "<option value="""&Right("0" & Trim(CStr(i)),2)&""">" & Trim(CStr(i))& "</option>" & vbcrlf
Next
GetRecordSearchForm = GetRecordSearchForm & "</select>"
GetRecordSearchForm = GetRecordSearchForm & " <input type=""submit"" value=""查看当日归档新闻"">"
GetRecordSearchForm = GetRecordSearchForm & "</td>"
GetRecordSearchForm = GetRecordSearchForm & "</form>"
GetRecordSearchForm = GetRecordSearchForm & "</tr></table>"
End Function
Function MoveNewsFile(IDList,SourceClassID,TargetClassID)
'如果IDList不为空，则SourceClass为1时IDLis为新闻ID，为2时则IDLis为下载
'如果IDlist为空时，则SourceClass为要转移的类的 ID
Dim SqlStr,RsSource,RsTarget
Dim FSO,FolderObj,FilesObj,FileObj
Dim SourceDir,TarGetDir,sRootDir,DatePathStr
Set FSO = Server.CreateObject(G_FS_FSO)
If SysRootDir<>"" then
sRootDir="/" & SysRootDir
Else
sRootDir=""
End If
If IdList<>"" then
IDList=replace(IDList,"***","','")
If SourceClassID="1" then
SqlStr="Select FS_NewsClass.ClassEName,FS_NewsClass.SaveFilePath,FS_News.Path,FS_News.FileName,FS_News.FileExtName from FS_News,FS_NewsClass where FS_News.ClassID=FS_NewsClass.ClassID and FS_News.NewsID in('" & IDList & "')"
Else
SqlStr="Select FS_NewsClass.ClassEName,FS_NewsClass.SaveFilePath,FS_Download.FileName,FS_Download.FileExtName from FS_Download,FS_NewsClass where FS_Download.ClassID=FS_NewsClass.ClassID and FS_Download.DownloadID in('" & IDList & "')"
End If
Else
SqlStr="Select FS_NewsClass.ClassEName,FS_NewsClass.SaveFilePath,FS_News.Path,FS_News.FileName,FS_News.FileExtName from FS_News,FS_NewsClass where FS_News.ClassID=FS_NewsClass.ClassID and FS_NewsClass.ClassID='" & SourceClassID & "'"
End If
Set RsSource=Conn.ExeCute(SqlStr)
Set RsTarget=Conn.ExeCute("Select ClassEName,SaveFilePath From FS_NewsClass where ClassID='" & TargetClassID & "'")
Do while Not RsSource.eof
'得到日期路径
If Application(LoginCacheNameStr)(21)="1" and SourceClassID="1" then DatePathStr=RsSource("Path") Else DatePathStr=""
'源文件路径
SourceDir=sRootDir & RsSource("SaveFilePath") & "/" & RsSource("ClassEName") & DatePathStr & "/" & RsSource("FileName") & "." & RsSource("FileExtName")
'目标文件路径
TarGetDir=sRootDir & RsTarget("SaveFilePath") & "/" & RsTarget("ClassEName") & DatePathStr & "/" & RsSource("FileName") & "." & RsSource("FileExtName")
SourceDir=Server.MapPath(SourceDir)
TarGetDir=Server.MapPath(TarGetDir)
if (FSO.FileExists(SourceDir)) then
'如果目录不存在，则创建目录
CreatMoreDir TarGetDir,instr(TarGetDir,replace(RsTarget("SaveFilePath"),"/","\"))
FSO.MoveFile SourceDir,TarGetDir
End If
RsSource.MoveNext
Loop
'--------------------------------
'合并栏目时，用来转移栏目中的下载
If IDList="" then
SqlStr="Select FS_NewsClass.ClassEName,FS_NewsClass.SaveFilePath,FS_Download.FileName,FS_Download.FileExtName from FS_Download,FS_NewsClass where FS_Download.ClassID=FS_NewsClass.ClassID and FS_NewsClass.ClassID='" & SourceClassID & "'"
Set RsSource=Conn.ExeCute(SqlStr)
Do while Not RsSource.eof
'源文件路径
SourceDir=sRootDir & RsSource("SaveFilePath") & "/" & RsSource("ClassEName") & "/" & RsSource("FileName") & "." & RsSource("FileExtName")
'目标文件路径
TarGetDir=sRootDir & RsTarget("SaveFilePath") & "/" & RsTarget("ClassEName") & "/" & RsSource("FileName") & "." & RsSource("FileExtName")
SourceDir=Server.MapPath(SourceDir)
TarGetDir=Server.MapPath(TarGetDir)
if (FSO.FileExists(SourceDir)) then
'如果目录不存在，则创建目录
CreatMoreDir TarGetDir,instr(TarGetDir,replace(RsTarget("SaveFilePath"),"/","\"))
FSO.MoveFile SourceDir,TarGetDir
End If
RsSource.MoveNext
Loop
End If
'------------------------------------
Set FSO = Nothing
Set RsSource = Nothing
Set RsTarget = Nothing
End Function
Function CreatMoreDir(DirStr,iBegin)
Dim sBuild,sDir,FSO
Set FSO = Server.CreateObject(G_FS_FSO)
sBuild = left(DirStr,iBegin - 1)
sDir = Mid(DirStr,iBegin)
While InStr(2, sDir,"\") > 1
sBuild = sBuild & left(sDir,InStr(2,sDir,"\") - 1)
sDir = Mid(sDir,InStr(2,sDir,"\"))
If (FSO.FolderExists(sBuild)) then
else
FSO.CreateFolder(sBuild)
End IF
Wend
set FSO=Nothing
End Function
Function AutoSplitPages(StrNewsContent)
Dim Inti,StrTrueContent,iPageLen,DLocation,XLocation,FoundStr
If StrNewsContent<>"" and AutoPagesNum<>0 and instr(1,StrNewsContent,"[Page]")=0 then
Inti=instr(1,StrNewsContent,"<")
If inti>=1 then '新闻中存在Html标记
StrTrueContent=left(StrNewsContent,Inti-1)
iPageLen=IStrLen(StrTrueContent)
inti=inti+1
Else '新闻中不存在Html标记，对内容直接分页即可
dim i,c,t
do while i< len(StrNewsContent)
i=i+1
c=Abs(Asc(Mid(StrNewsContent,i,1)))
if c>255 then '判断为汉字则为两个字符，英文为一个字符
t=t+2
else
t=t+1
end if
if t>=AutoPagesNum then '如果字数达到了分页的数量则插入分页符号
StrNewsContent=left(StrNewsContent,i)&"[Page]"&mid(StrNewsContent,i+1)
i=i+6
t=0
end if
loop
AutoSplitPages=StrNewsContent '返回插入分页符号的内容
Exit Function
End If
iPageLen=0
'新闻中存在Html标记时，则用下面的语句来处理
do while instr(Inti,StrNewsContent,">")<>0
DLocation=instr(Inti,StrNewsContent,">") '只计算Html标记之外的字符数量
XLocation=instr(DLocation,StrNewsContent,"<")
If XLocation>DLocation+1 then
Inti=XLocation
StrTrueContent=mid(StrNewsContent,DLocation+1,XLocation-DLocation-1)
iPageLen=iPageLen+IStrLen(StrTrueContent) '统计Html之外的字符的数量
If iPageLen>AutoPagesNum then '如果达到了分页的数量则插入分页字符
FoundStr=Lcase(left(StrNewsContent,XLocation-1))
If AllowSplitPages(FoundStr,"table|a|b>|i>|strong|div")=true then
StrNewsContent=left(StrNewsContent,XLocation-1)&"[Page]"&mid(StrNewsContent,XLocation)
iPageLen=0 '重新统计Html之外的字符
End If
End If
ElseIf XLocation=0 then '在后面再也找不到<，即后面没有Html标记了
Exit Do
ElseIf XLocation=DLocation+1 then '找到的Html标记之间的内容为空，则继续向后找
Inti=XLocation
End If
loop
End If
AutoSplitPages=StrNewsContent
End Function
Function AllowSplitPages(TempStr,FindStr)
Dim Inti,BeginStr,EndStr,BeginStrNum,EndStrNum,ArrStrFind,i
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
AllowSplitPages=true
Else
AllowSplitPages=False
Exit Function
End If
Next
Else
AllowSplitPages=False
End If
End Function
Function WebDomain
Dim LocalPort
If Request.ServerVariables("SERVER_PORT")<>"80" Then
LocalPort=":"&Request.ServerVariables("SERVER_PORT")
Else
LocalPort=""
End If
WebDomain="http://"&Request.ServerVariables("SERVER_NAME")&LocalPort
End Function
Function Get_Forward_And_Backward_News_Str(f_News_ID,f_Class_ID,FordwardTF)
Dim FS_NextTempStr,FS_PreviousTempStr,NextSql,NextRs
if FordwardTF then
NextSql = "Select TOP 1 FS_news.title,FS_news.Path,FS_news.FileName,FS_news.FileExtName,FS_NewsClass.ClassEName From FS_News,FS_newsclass where FS_News.HeadNewsTF=0 and FS_News.DelTF=0 and FS_News.ID < (Select ID from FS_News where NewsID='" & f_News_ID & "') and FS_News.ClassID = '" & f_Class_ID & "' and FS_News.ClassID=FS_NewsClass.ClassID order by FS_News.id desc"
Set NextRs = Conn.Execute(NextSql)
If NextRs.eof or NextRs.bof Then
FS_PreviousTempStr = "没有了"
Else
if Application(LoginCacheNameStr)(21)="1" then
FS_PreviousTempStr = "<a href='../.." & NextRs("path") & "/" & NextRs("FileName") & "." & NextRs("FileExtName") & "' title ='"&NextRs("Title")&"'>"&NextRs("Title")&"</a>"
else
FS_PreviousTempStr = "<a href='" & NextRs("FileName") & "." & NextRs("FileExtName") & "' title ='"&NextRs("Title")&"'>"&NextRs("Title")&"</a>"
end if
End If
NextRs.Close
Set NextRs = nothing
Get_Forward_And_Backward_News_Str = FS_PreviousTempStr
else
NextSql = "Select TOP 1 FS_news.title,FS_news.Path,FS_news.FileName,FS_news.FileExtName,FS_NewsClass.ClassEName From FS_News,FS_newsclass where FS_News.HeadNewsTF=0 and FS_News.DelTF=0 and FS_News.ID > (Select ID from FS_News where NewsID='" & f_News_ID & "') and FS_News.ClassID = '" & f_Class_ID & "' and FS_News.ClassID=FS_NewsClass.ClassID order by FS_News.id"
Set NextRs = Conn.Execute(NextSql)
If NextRs.eof or NextRs.bof Then
FS_NextTempStr = "没有了"
Else
if Application(LoginCacheNameStr)(21)="1" then
FS_NextTempStr = "<a href='../.." & NextRs("path") & "/" & NextRs("FileName") & "." & NextRs("FileExtName") & "' title ='"&NextRs("Title")&"'>"&NextRs("Title")&"</a>"
else
FS_NextTempStr = "<a href='" & NextRs("FileName") & "." & NextRs("FileExtName") & "' title ='"&NextRs("Title")&"'>"&NextRs("Title")&"</a>"
end if
End If
NextRs.Close
Set NextRs = nothing
Get_Forward_And_Backward_News_Str = FS_NextTempStr
end If
End Function
%>⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -