📄 cs_function.asp
字号:
GetOneNewsReturnValue = GetOneNewsReturnValue & "<br> <strong>新闻链接</strong>： <a target=""_blank"" href=""" & LinkStr & """>" & LinkStr & "</a><br>"
Case 3 '内容为空，没有保存
GetOneNewsReturnValue = "</br> <strong>序号</strong>： " & NewsIndex
GetOneNewsReturnValue = GetOneNewsReturnValue & " <strong>结果</strong>： <font color=red>内容为空，没有保存</font>"
GetOneNewsReturnValue = GetOneNewsReturnValue & "<br> <strong>标题</strong>： " & Title
GetOneNewsReturnValue = GetOneNewsReturnValue & "<br> <strong>新闻链接</strong>： <a target=""_blank"" href=""" & LinkStr & """>" & LinkStr & "</a><br>"
Case 4 '成功保存
GetOneNewsReturnValue = "</br> <strong>序号</strong>： " & NewsIndex
GetOneNewsReturnValue = GetOneNewsReturnValue & " <strong>结果</strong>： 采集成功"
GetOneNewsReturnValue = GetOneNewsReturnValue & "<br> <strong>标题</strong>： " & Title
GetOneNewsReturnValue = GetOneNewsReturnValue & "<br> <strong>内容</strong>： " & Left(LoseHtml(Content),30) & " ......"
GetOneNewsReturnValue = GetOneNewsReturnValue & "<br> <strong>新闻链接</strong>： <a target=""_blank"" href=""" & LinkStr & """>" & LinkStr & "</a><br>"
CollectOKNumber = CollectOKNumber + 1
Case 5 '不能够读取新闻目标页面
GetOneNewsReturnValue = "</br> <strong>序号</strong>： " & NewsIndex
GetOneNewsReturnValue = GetOneNewsReturnValue & " <strong>结果</strong>： <font color=red>不能够读取新闻目标页面</font>"
GetOneNewsReturnValue = GetOneNewsReturnValue & "<br> <strong>新闻链接</strong>： <a target=""_blank"" href=""" & LinkStr & """>" & LinkStr & "</a><br>"
Case else
End Select
End Function
Function SaveCollectContent(Title,Links,Content,Author,SourceString,AddDate)
Dim RsNewsObj,RsTempObj
Set RsNewsObj = Server.CreateObject("Adodb.RecordSet")
RsNewsObj.Open "Select * from FS_News where 1=0",CollectConn,3,3
RsNewsObj.AddNew
RsNewsObj("Title") = LoseHtml(Title)
RsNewsObj("Links") = Links
RsNewsObj("Content") = Content
RsNewsObj("ContentLength") = Len(Content)
RsNewsObj("AddDate") = AddDate
RsNewsObj("ImagesCount") = 0
RsNewsObj("SiteID") = CollectingSiteID
RsNewsObj("Author") = Left(Author,200)
If AuditTF = False Then
RsNewsObj("IsLock") = 1
Else
RsNewsObj("IsLock") = 0
End If
If AutoCollect Then
RsNewsObj("History") = 1
End If
RsNewsObj("Source") = Left(SourceString,200)
RsNewsObj("ReviewTF") = 0
RsNewsObj.UpDate
RsNewsObj.Close
Set RsNewsObj = Nothing
If AutoCollect Then
NewsToSystem Title,Content,Author,SourceString,AddDate
End If
End Function
Function ReplaceKeyWords(Content)
Dim RsRuleObj,HeadSeting,FootSeting,ReContent,regEx
IF CS_SiteReKeyID = "" Or IsNull(CS_SiteReKeyID) Then
ReplaceKeyWords = Content
Exit Function
End IF
Set RsRuleObj = CollectConn.Execute("Select * from FS_Rule where ID In(" & CS_SiteReKeyID & ")")
do while Not RsRuleObj.Eof
HeadSeting = RsRuleObj("HeadSeting")
FootSeting = RsRuleObj("FootSeting")
ReContent = RsRuleObj("ReContent")
if IsNull(FootSeting) or FootSeting = "" then
if HeadSeting <> "" then
Content = Replace(Content,HeadSeting,ReContent)
end if
end if
if Not IsNull(FootSeting) and FootSeting <> "" and Not IsNull(HeadSeting) and HeadSeting <> "" then
Set regEx = New RegExp
regEx.Pattern = HeadSeting & "[^\0]*" & FootSeting
regEx.IgnoreCase = False
regEx.Global = True
if IsNull(ReContent) then
Content = regEx.Replace(Content,"")
else
Content = regEx.Replace(Content,ReContent)
end if
Set regEx = Nothing
end if
RsRuleObj.MoveNext
loop
Set RsRuleObj = Nothing
ReplaceKeyWords = Content
End Function
Function NewsToSystem(Title,Content,Author,SourceString,AddDate)
Dim f_Field_Array,f_Source_Sql,f_Object_Sql,f_Collect_RS,f_System_RS,f_i,TempNewsID,f_System_RS_Pop,OldID,Fs_news
Dim Str_Temp_Flag,temp_j,StrSql,p_File_Ext_Name,p_Save_Path,sRootDir,str_CurrPath
if G_VIRTUAL_ROOT_DIR<>"" then sRootDir="/" & G_VIRTUAL_ROOT_DIR else sRootDir=""
If Session("Admin_Is_Super") = 1 then
str_CurrPath = sRootDir &"/"&G_UP_FILES_DIR
Else
If Session("Admin_FilesTF") = 0 Then
str_CurrPath = Replace(sRootDir &"/"&G_UP_FILES_DIR&"/adminfiles/"&UCase(md5(Session("Admin_Name"),16)),"//","/")
Else
str_CurrPath = sRootDir &"/"&G_UP_FILES_DIR
End If
End if
Set Fs_news = New Cls_News
Fs_News.GetSysParam()
If Not Fs_news.IsSelfRefer Then
p_File_Ext_Name = "html"
p_Save_Path = "/" & Year(Now) & "-" & Month(Now) & "-" & Day(Now)
else
p_File_Ext_Name = Fs_News.fileExtName
p_Save_Path = Fs_news.SaveNewsPath(Fs_news.fileDirRule)
end if
'-----2006-12-07 by ken 采集数据转移到主数据库时候，设置生成静态文件扩展名
If p_File_Ext_Name <> "html" Then
If CInt(p_File_Ext_Name) = 0 then
p_File_Ext_Name = "html"
ElseIf CInt(p_File_Ext_Name) = 1 then
p_File_Ext_Name = "htm"
ElseIf CInt(p_File_Ext_Name) = 2 then
p_File_Ext_Name = "shtml"
ElseIf CInt(p_File_Ext_Name) = 3 then
p_File_Ext_Name = "shtm"
ElseIf CInt(p_File_Ext_Name) = 4 then
p_File_Ext_Name = "asp"
Else
p_File_Ext_Name = "html"
End If
End If
StrSql="INSERT INTO FS_NS_News([NewsID],[PopId],[ClassID],[NewsTitle],[isShowReview],[Content],[Templet],[Source],[Author],[SaveNewsPath],[FileName],[FileExtName],[NewsProperty],[isLock],[addtime],[isPicNews],[NewsPicFile],[NewsSmallPicFile]) VALUES ("
TempNewsID=GetRamCode(15)
StrSql=StrSql & "'" & TempNewsID & "'"
StrSql=StrSql & ",0"
StrSql=StrSql & ",'" & GetNewsInfoBySiteID(CollectingSiteID,"ClassID") & "'"
StrSql=StrSql & ",'"&Title&"'"
StrSql=StrSql & ",0"
StrSql=StrSql & ",'"&Replace(Content,"'","''")&"'"
StrSql=StrSql & ",'"&GetNewsInfoBySiteID(CollectingSiteID,"Temp")&"'"
StrSql=StrSql & ",'"&left(SourceString,50)&"'"
StrSql=StrSql & ",'"&Left(Author,50)&"'"
StrSql=StrSql & ",'"&Fs_news.SaveNewsPath(Fs_news.fileDirRule)&"'"
'------
OldID = Fs_News.strFileNameRule(Fs_News.fileNameRule,0,0)
if instr(OldID,"自动编号ID") > 0 then OldID = Replace(OldID,"自动编号ID",TempNewsID)
if instr(OldID,"唯一NewsID") > 0 then OldID = Replace(OldID,"唯一NewsID",TempNewsID)
'------
StrSql=StrSql & ",'"&OldID&"'"
StrSql=StrSql & ",'"&p_File_Ext_Name&"'"
StrSql=StrSql & ",'0,1,1,0,1,0,0,0,1,0,0'"
If AuditTF = False Then
StrSql=StrSql & ",1"
Else
StrSql=StrSql & ",0"
End If
StrSql=StrSql & ",'"&AddDate&"'"
If GetCeSitePicTF(CollectingSiteID) = True Then
If ContentInnerPicTF(Replace(Content,"'","''"),"TF") = True Then
StrSql = StrSql & ",1"
StrSql = StrSql & ",'" & ContentInnerPicTF(Replace(Content,"'","''"),"PicUrl") & "'"
StrSql = StrSql & ",'" & ContentInnerPicTF(Replace(Content,"'","''"),"PicUrl") & "'"
Else
StrSql = StrSql & ",0"
StrSql = StrSql & ",''"
StrSql = StrSql & ",''"
End If
Else
StrSql = StrSql & ",0"
StrSql = StrSql & ",''"
StrSql = StrSql & ",''"
End If
'====End=====================
StrSql=StrSql & ")"
'On Error Resume Next
If StrSql<>"" Then
Conn.Execute(StrSql)
End If
Set Fs_news = Nothing
NewsToSystem = True
End Function
'----
Function NUllToStr(num)
If IsNull(num) Or num = "" Then
NUllToStr = 0
Else
If Not IsNumeric(num) Then
NUllToStr = 0
Else
NUllToStr = Cint(num)
End If
End if
End Function
'===========================================================
'判断传入的字符传中是否包含本地图片并取得此图片地址
'===========================================================
Function ContentInnerPicTF(StrCon,ReturnTF)
Dim ConStr,Re,InnerPicAll,FistPicUrl,PicUrlStr
ConStr = StrCon & ""
Set Re = New RegExp
Re.IgnoreCase = True
Re.Global = True
Re.Pattern = "(src\S+\.{1}(gif|jpg|png)(""|\'|>|\s)?)"
InnerPicAll = ""
Set InnerPicAll = Re.Execute(ConStr)
Set Re = Nothing
FistPicUrl = ""
For Each PicUrlStr in InnerPicAll
FistPicUrl = Replace(Replace(Replace(PicUrlStr,"src=",""),"'",""),"""","")
If LCase(Left(FistPicUrl,Len(sRootDir))) = LCase(sRootDir) Then
FistPicUrl = Mid(FistPicUrl,Len(sRootDir)+1)
End If
Exit For
Next
If ReturnTF = "TF" Then
If FistPicUrl <> "" And (Not IsNull(FistPicUrl)) then
ContentInnerPicTF = True
Else
ContentInnerPicTF = False
End If
ElseIf ReturnTF = "PicUrl" Then
If FistPicUrl <> "" And (Not IsNull(FistPicUrl)) then
ContentInnerPicTF = FistPicUrl
End If
End If
End Function
'===========================================================
'判断传入的采集站点设置属性
'===========================================================
Function GetCeSitePicTF(SiteID)
Dim GetSiteRs
IF SiteID = "" Then : GetCeSitePicTF = False : Exit Function
SiteID = Clng(SiteID)
Set GetSiteRs = CollectConn.ExeCute("Select IsAutoPicNews From FS_Site Where ID = " & SiteID & " And IsLock = 0")
If GetSiteRs.Eof Then
GetCeSitePicTF = False
Else
If GetSiteRs(0) = 1 Then
GetCeSitePicTF = True
Else
GetCeSitePicTF = False
End If
End If
GetSiteRs.Close : Set GetSiteRs = NoThing
End Function
Function GetNewsInfoBySiteID(SiteID,Act)
Dim GetSiteRs
IF SiteID = "" Or IsNull(SiteID) Or NOt IsNumeric(SiteID) Then
If Act = "ClassID" Then
GetNewsInfoBySiteID = 0
Else
GetNewsInfoBySiteID = "/" & G_TEMPLETS_DIR & "/NewsClass/new.htm"
End IF
End If
Set GetSiteRs = CollectConn.ExeCute("Select ToClassID,NewsTemplets From FS_Site Where ID = " & SiteID & " And IsLock = 0")
If GetSiteRs.Eof Then
If Act = "ClassID" Then
GetNewsInfoBySiteID = 0
Else
GetNewsInfoBySiteID = "/" & G_TEMPLETS_DIR & "/NewsClass/new.htm"
End IF
Else
If Act = "ClassID" Then
GetNewsInfoBySiteID = GetSiteRs(0)
Else
GetNewsInfoBySiteID = GetSiteRs(1)
End IF
End If
GetSiteRs.Close : Set GetSiteRs = NoThing
End Function
%>⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -