common.asp

新闻发布系统

<!--#include file="const.asp"-->
<%
Function CheckStr(str)
    If IsNull(str) Then
        CheckStr = ""
        Exit Function
    End If
    CheckStr = Replace(str, "'", "''")
End Function
function SetTitle(byval strTitle) SetTitle = "<script>top.document.title='" & strTitle & "';</script>" end function
Function FindStringPlus(strContent, start_string, end_string)
    On Error Resume Next
    MARKCOUNTS = UBound(Split(strContent, start_string))
    PRESTRING = strContent
    For I = 0 To MARKCOUNTS
        STARTMARK = InStr(1, PRESTRING, start_string, 1)
        If STARTMARK = 0 Then Exit For
        COMPMARK = InStr(1, PRESTRING, end_string, 1) + Len(end_string)
        VerString = Mid(PRESTRING, STARTMARK, COMPMARK - STARTMARK)
        VeriableString = Replace(VerString, start_string, "")
        VeriableString = Replace(VeriableString, end_string, "")
        PRESTRING = Replace(PRESTRING, VerString, "")
        If I = 0 Then spString = "" Else spString = "|"
        FindStringPlus = FindStringPlus & spString
    Next
End Function

Function replaceplus(strContent, start_string, end_string, replace_string)
    On Error Resume Next
    MARKCOUNTS = UBound(Split(strContent, start_string))
    PRESTRING = strContent
    For I = 0 To MARKCOUNTS
        STARTMARK = InStr(1, PRESTRING, start_string, 1)
        If STARTMARK = 0 Then Exit For
        COMPMARK = InStr(1, PRESTRING, end_string, 1) + Len(end_string)
        VerString = Mid(PRESTRING, STARTMARK, COMPMARK - STARTMARK)
        PRESTRING = Replace(PRESTRING, VerString, replace_string)
    Next
    replaceplus = PRESTRING
    If Err.Number <> 0 Then Err.Clear
End Function

function GetfileExt(byval filename)
	fileExt_a=split(filename,".")
	GetfileExt=lcase(fileExt_a(ubound(fileExt_a)))
end function




function HTTPGET_BODY_EXAM(byval NEWSLIST_DATA,START1,END1)
	PRESTRING = NEWSLIST_DATA
	HTMLDATA = NEWSLIST_DATA
	headmark = START1
	footmark = END1
	STARTMARK=1
	do
		STARTMARK=instr(STARTMARK,PRESTRING,headmark,1)
		if STARTMARK=0 then exit do
		ENDMARK=instr(STARTMARK,PRESTRING,footmark,1)
		if ENDMARK=0 then exit do
		ENDMARK2=instr(1,PRESTRING,FOOTMARK,1) + len(FOOTMARK)
		tmp_string = mid(PRESTRING,STARTMARK,ENDMARK2-STARTMARK)
		VeriableString = replace(replace(replace(tmp_string,headmark,""),footmark,""),"|","/")
		HTMLDATA = replace(HTMLDATA,tmp_string,"")
		PRESTRING = replace(PRESTRING,tmp_string,"")
		count = count +1
	loop
	HTTPGET_BODY_EXAM = VeriableString
end function



function MIDPlus_cms(byval data_string,Label,t_f)
	if t_f = 0 then
		MIDPlus_cms = mid(data_string,1,instr(data_string,label)-1)
	end if
	if t_f = 1 then
		MIDPlus_cms = mid(data_string,instr(data_string,label)+len(label),len(data_string)-instr(data_string,label)+len(label))
	end if
end function

sub cms_error(byval errortips)
	response.Write errortips
	response.write cms_label_for_template("{PointsmanTeam:DATA}","1")
	response.End
end sub

sub cms_ok(byval oktips)
	response.Write oktips
	response.write cms_label_for_template("{PointsmanTeam:DATA}","1")
	response.End
end sub



sub RecordLog(byval LoginID, functionid, actionid, operation, Date_Time, IP)
	conn.execute("sp_s_RecordLog " & LoginID & ",'" & functionid & "','" & actionid & "','" & operation & "','" & Date_Time & "','" & IP & "'")
end sub



Function chkemail(strEmailAddr) ' vbs
    Dim re
    Set re = new RegExp
    re.pattern = "^[a-zA-Z][A-Za-z0-9_.-]+@[a-zA-Z0-9_]+?\.[a-zA-Z]{2,3}$"
    chkemail=re.Test(strEmailAddr)
end function

Function chkoicq(oicq) 'vbs
    Dim re1
    Set re1 = new RegExp
    re1.IgnoreCase = false
    re1.global = false
    re1.Pattern = "[0-9]{4,9}$"
    chkoicq = re1.Test(oicq)
End Function


function GetPathList(ClassID,gotourl) '获取分类路径
	set rs= conn.execute("select class_name,Depth,ParentID from tblCategory  where class_id='"& ClassID & "'")
	if not (rs.eof and rs.bof) then
		Depth = rs(1)
		lpath = rs(0)
		ParentID = rs(2)
		rs.close
		set rs=nothing
		for i=1 to Depth
			set rstmp= conn.execute("select class_id,class_name,ParentID from tblCategory  where class_id='"& ParentID & "'")
			ParentID = rstmp(2)
			path = "<a href=" & gotourl & "?fromScripts=" & CurrentScript & "&sortid=" & rstmp(0) & ">" & rstmp(1) & "</a> → " & path 
			set rstmp=nothing
		next
		GetPathList = "<a href=" & gotourl & "?fromScripts=" & CurrentScript & "&sortid=0>首页</a> → " & path & lpath
	else
		GetPathList = 0
	end if
end function


function GetDownloadPathList(ClassID,gotourl) '获取分类路径
	set rs= conn.execute("select class_name,Depth,ParentID from tblDownloadCategory  where class_id='"& ClassID & "'")
	if not (rs.eof and rs.bof) then
		Depth = rs(1)
		lpath = rs(0)
		ParentID = rs(2)
		rs.close
		set rs=nothing
		for i=1 to Depth
			set rstmp= conn.execute("select class_id,class_name,ParentID from tblDownloadCategory  where class_id='"& ParentID & "'")
			ParentID = rstmp(2)
			path = "<a href=" & gotourl & "?fromScripts=" & CurrentScript & "&sortid=" & rstmp(0) & ">" & rstmp(1) & "</a> → " & path 
			set rstmp=nothing
		next
		GetDownloadPathList = path & lpath
	else
		GetDownloadPathList = 0
	end if
end function

function GetPathListInHTML(ClassID,gotourl) '获取分类路径
	set rs=server.CreateObject("adodb.recordset")
	sql = "select class_name,Depth,ParentID from tblCategory  where class_id='"& ClassID & "'"
	rs.open sql,conn,1,1
	if rs.recordcount>0 then
		Depth = rs(1)
		lpath = rs(0)
		ParentID = rs(2)
	else
		parentid=0
	end if
	rs.close
	set rs=nothing
	for i=1 to Depth
		set rs= conn.execute("select class_id,class_name,ParentID from tblCategory  where class_id='"& ParentID & "'")
		ParentID = rs(2)
		path =  rs(1) & " → " & path 
		set rs=nothing
	next
	GetPathListInHTML = "<a href=/>首　　页</a> → " & path & lpath
end function

sub RestoreDefaultSetting()
' 2003-08-22 update system default setting strings.
	DefaultString = "U2l0ZU1hbmFnZXIgzfjVvrncwO3Ptc2zLGh0dHA6Ly93d3cuY256b25lLm5ldCxTaXRlTWFuYWdlciwxMjcuMC4wLjEsd2VibWFzdGVyQGNuem9uZS5uZXQsMiwxMjcuMC4wLjEsMCxkZWZhdWx0Lmh0bSwwLDEsNTEyLEdJRnxKUEd8UE5HfEJNUHxUWFR8SFRNfEhUTUx8WklQfFJBUnxSTXxNUEd8RE9DfFBQVHxYU0wsMTUwLDE1MCwwLDEsMCwwLDI1LFNpdGVNYW5hZ2VyfEphcm9uLDxMST4sU0lURU1BTkFHRVJfQkFDS1VQX0RJUg=="
	call RecordLog(LoginID, 0, 0, "恢复系统默认配置", now(), USER_IP)
	conn.execute("delete tblConfig")
	conn.execute("insert into tblConfig (SystemParameter) values ('" & DefaultString & "')")
end sub

' ============== autoget ==============

Function NewsFairy_for_sina(autoid,str,NewsLength,NeedTime)
	If NeedTime<>True then
		Left_0=Instr(str,"</a>")+3
		TheRed=Instr(str,"<font color=#ff0000>")
		If TheRed>0 then
			Left_1=Instr(str,"<font color=#ff0000>")+20
			Left_2=Instr(str,"</font>")
			If Left_1+NewsLength>=Left_2 then
				NewsFairy_for_sina=Left(str,Left_0)
			Else
				NewsFairy_for_sina=Left(str,Left_1+NewsLength)&Points&"</font></a>"
			End if
		Else
			Left_1=Instr(str,"_blank>")+7
			Left_2=Instr(str,"</a>")
			If Left_1+NewsLength>=Left_2 then
				NewsFairy_for_sina=Left(str,Left_0)
			Else