messanger.asp

品泡女人香XI8.NET文章管理系统的源码

		If Rs.eof And Rs.bof Then
			ErrCodes=ErrCodes+"<li>"+template.Strings(35):Exit Sub
		ELSE
			InceptName=RS(0)
		End If
		Rs.close
		If CHKHateName(InceptName) Then
			ErrCodes=ErrCodes+"<li>"+Replace(template.Strings(64),"{$incept}",InceptName)
			Exit Sub
		Else
			If Request.Form("sms_act")="Sms_Issend" Then
				Sql="insert into Dv_Message (incept,sender,title,content,sendtime,flag,issend) values ('"&InceptName&"','"&Dvbbs.MemberName&"','"&title&"','"&message&"',"&SqlNowString&",0,1)"
				subtype=BoxName(2)		'已发送的消息
				SendNum = SendNum + 1
			ElseIf Request.Form("sms_act")="Sms_Issave" Then
				Sql="insert into Dv_Message (incept,sender,title,content,sendtime,flag,issend) values ('"&InceptName&"','"&Dvbbs.MemberName&"','"&title&"','"&message&"',"&SqlNowString&",0,0)"
				subtype=BoxName(4)		'发件箱
			Else
				Sql="insert into Dv_Message (incept,sender,title,content,sendtime,flag,issend) values ('"&InceptName&"','"&Dvbbs.MemberName&"','"&title&"','"&message&"',"&SqlNowString&",0,1)"
				subtype=BoxName(2)		'已发送的消息
				SendNum = SendNum + 1
			End If
			Dvbbs.execute(sql)
			UPDATE_User_Msg(InceptName)
		End IF
		If i>Cint(Dvbbs.GroupSetting(33))-1 Then
			ErrCodes=ErrCodes+"<li>"+Replace(template.Strings(55),"{$Sms_MaxSend}",Dvbbs.GroupSetting(33))
			EXIT Sub
		EXIT For
		End If
	NEXT
	'更新用户当日发短信数据以及缓存
	If SendNum > 0 Then
		Dim iUserInfo
		iUserInfo = Session(Dvbbs.CacheName & "UserID")
		iUserInfo(36) = Dvbbs.UserToday(0) & "|" & Dvbbs.UserToday(1) + SendNum & "|" & Dvbbs.UserToday(2)
		iUserInfo(37) = ""
		Session(Dvbbs.CacheName & "UserID") = iUserInfo
		Dvbbs.Execute( "Update [Dv_User] Set UserToday='" & iUserInfo(36) & "' Where UserID = " & Dvbbs.UserID)
	End If
	Response.Cookies("Dvbbs")=Dvbbs.Boardid
	Dvbbs.Dvbbs_Suc("<li>"+Replace(template.Strings(38),"{$SmsBOX}",subtype))
End Sub

'保存修改
Sub savedit()
Dim incept,title,message,subtype
If Clng(Dvbbs.GroupSetting(53))>0 And DateDiff("s",Session(Dvbbs.CacheName & "UserID")(14),Now)<Clng(Dvbbs.GroupSetting(53))*60 Then
	ErrCodes=ErrCodes+"<li>"+Replace(template.Strings(39),"{$Lim_Time}",Dvbbs.GroupSetting(53))
	Exit Sub
End If
If CheckID(id) = False Then
	ErrCodes=ErrCodes+"<li>"+template.Strings(51)
	Exit Sub
End If
If Request("touser")="" Then
	ErrCodes=ErrCodes+"<li>"+template.Strings(35)
	Exit Sub
Else
	incept=Dvbbs.checkStr(Request.Form("touser"))
End If
If Request("title")="" or Dvbbs.StrLength(Request("title")) > 50 Then
	ErrCodes=ErrCodes+"<li>"+template.Strings(53)
	Exit Sub
Else
	title=Dvbbs.checkStr(Request.Form("title"))
End If
If Request("message")="" or Dvbbs.StrLength(Request("message")) > CLng(Dvbbs.GroupSetting(34)) Then
	ErrCodes=ErrCodes+"<li>"+Replace(template.Strings(54),"{$MaxLen}",Dvbbs.GroupSetting(34))
	Exit Sub
Else
	message=Html2Ubb(Request.form("message"))
	message=Dvbbs.checkStr(message)
End If

Dim SendNum
SendNum = 0
Sql="SELECT UserName FROM [Dv_User] WHERE UserName='"&incept&"'"
Set Rs=Dvbbs.execute(sql)
If Rs.eof And Rs.bof Then
	ErrCodes=ErrCodes+"<li>"+template.Strings(35)
	Exit Sub
End If
Rs.close:Set Rs=Nothing
If Request("Submit")="Sms_Issend" Then
	Sql="UPDATE Dv_Message Set incept='"&incept&"',title='"&title&"',content='"&message&"',sendtime="&SqlNowString&",flag=0,issend=1 WHERE id="&Dvbbs.checkStr(id)
	subtype="发送箱"
	SendNum = 1
Else
	Sql="UPDATE Dv_Message Set incept='"&incept&"',title='"&title&"',content='"&message&"',sendtime="&SqlNowString&",flag=0,issend=0 WHERE id="&Dvbbs.checkStr(id)
	subtype="发件箱"
End If
Dvbbs.execute(sql)

'更新用户当日发短信数据以及缓存
If SendNum > 0 Then
	Dim iUserInfo
	iUserInfo = Session(Dvbbs.CacheName & "UserID")
	iUserInfo(36) = Dvbbs.UserToday(0) & "|" & Dvbbs.UserToday(1) + SendNum & "|" & Dvbbs.UserToday(2)
	Session(Dvbbs.CacheName & "UserID") = iUserInfo
	Dvbbs.Execute("Update [Dv_User] Set UserToday='" & iUserInfo(36) & "' Where UserID = " & Dvbbs.UserID)
End If
UPDATE_User_Msg(incept)
UPDATE_User_Msg(Dvbbs.membername)
Dvbbs.Dvbbs_Suc("<li>"+Replace(template.Strings(38),"{$SmsBOX}",subtype))
End Sub

'-------------------------------------------------------------逻辑删除-----------------------------------------
'收件逻辑删除，置于回收站，入口字段DelR，可用于批量及单个删除
Sub Delinbox()
If CheckID(id) = False Then
	ErrCodes=ErrCodes+"<li>"+template.Strings(51)
else
	Dvbbs.execute("UPDATE Dv_Message Set DelR=1 WHERE incept='"&Dvbbs.MemberName&"' And id in ("&Dvbbs.checkStr(id)&")")
	Dvbbs.Dvbbs_Suc("<li>"+template.Strings(36))
	UPDATE_User_Msg(Dvbbs.membername)
End If 
End Sub

Sub AllDelinbox()
	Dvbbs.execute("UPDATE Dv_Message Set DelR=1 WHERE incept='"&Dvbbs.MemberName&"' And DelR=0")
	Dvbbs.Dvbbs_Suc("<li>"+template.Strings(36))
	UPDATE_User_Msg(Dvbbs.membername)
End Sub

'发件逻辑删除，置于回收站，入口字段DelS，可用于批量及单个删除
Sub Deloutbox()
If CheckID(id) = False Then
	ErrCodes=ErrCodes+"<meta http-equiv=refresh content=""2;URL="&Request.ServerVariables("HTTP_REFERER")&"""><li>"+template.Strings(51)&"2秒后自动返回上一页"
Else
	Dvbbs.execute("UPDATE Dv_Message Set DelS=1 WHERE sender='"&Dvbbs.MemberName&"' And issend=0 And id in ("&Dvbbs.checkStr(id)&")")
	Dvbbs.Dvbbs_Suc("<li>"+template.Strings(36))
	UPDATE_User_Msg(Dvbbs.membername)
End If
End Sub

Sub AllDeloutbox()
	Dvbbs.execute("UPDATE Dv_Message Set DelS=1 WHERE sender='"&Dvbbs.MemberName&"' And DelS=0 And issend=0")
	Dvbbs.Dvbbs_Suc("<li>"+template.Strings(36))
	UPDATE_User_Msg(Dvbbs.membername)
End Sub

'已发送逻辑删除，置于回收站，入口字段DelS，可用于批量及单个删除
'DelS：0未操作，1发送者删除，2发送者从回收站删除
Sub DelISsend()
If CheckID(id) = False Then
	ErrCodes=ErrCodes+"<meta http-equiv=refresh content=""2;URL="&Request.ServerVariables("HTTP_REFERER")&"""><li>"+template.Strings(51)&"两秒后自动返回"
Else 
	Dvbbs.execute("UPDATE Dv_Message Set DelS=1 WHERE sender='"&Dvbbs.MemberName&"' And issend=1 And id in ("&Dvbbs.checkStr(id)&")")
	Dvbbs.Dvbbs_Suc("<li>"+template.Strings(36))
	UPDATE_User_Msg(Dvbbs.membername)
End If
End Sub

'将已发送的短信移到回收站。
Sub AllDelIssend()
	Dvbbs.execute("UPDATE Dv_Message Set DelS=1 WHERE sender='"&Dvbbs.MemberName&"' And DelS=0 And issend=1")
	Dvbbs.Dvbbs_Suc("<li>"+template.Strings(36))
	UPDATE_User_Msg(Dvbbs.membername)
End Sub

'用户能完全删除收到信息和逻辑删除所发送信息，逻辑删除所发送信息设置入口字段DelS参数为2
sub Delrecycle()
If CheckID(id) = False Then
	ErrCodes=ErrCodes+"<meta http-equiv=refresh content=""2;URL="&Request.ServerVariables("HTTP_REFERER")&"""><li>"+template.Strings(51)
	Exit Sub
Else
	Dvbbs.execute("DelETE FROM Dv_Message WHERE incept='"&Dvbbs.MemberName&"' And DelR=1 And id in ("&Dvbbs.checkStr(id)&")")
	Dvbbs.execute("UPDATE Dv_Message Set DelS=2 WHERE sender='"&Dvbbs.MemberName&"' And DelS=1 And id in ("&Dvbbs.checkStr(id)&")")
	Dvbbs.Dvbbs_Suc("<li>"+template.Strings(37))
	UPDATE_User_Msg(dvbbs.membername)
End If
End Sub

'收信人回收站： incept=收信人 DelR=1
'发信人回收站： sender=收信人 DelS=2
'清空及删除回收站记录，将不在回收站的记录放到回收站内
sub AllDelrecycle()
	Dvbbs.execute("DelETE FROM Dv_Message WHERE incept='"&Dvbbs.MemberName&"' And DelR=1")	
	Dvbbs.execute("UPDATE Dv_Message Set DelS=2 WHERE sender='"&Dvbbs.MemberName&"' And DelS=1")
	'sucmsg=sucmsg+"<br>"+"<li>删除短信息成功。删除的消息将不可恢复。"
	Dvbbs.Dvbbs_Suc("<li>"+template.Strings(37))
	UPDATE_User_Msg(Dvbbs.Membername)
End Sub

'删除的消息将置于您的回收站
Sub Delete()
If CheckID(id) = False Then
	ErrCodes=ErrCodes+"<meta http-equiv=refresh content=""2;URL="&Request.ServerVariables("HTTP_REFERER")&"""><li>"+template.Strings(51)
Else
	Dvbbs.execute("UPDATE Dv_Message Set DelR=1 WHERE incept='"&Dvbbs.MemberName&"' And id="&Dvbbs.checkStr(id))
	Dvbbs.execute("UPDATE Dv_Message Set DelS=1 WHERE sender='"&Dvbbs.MemberName&"' And id="&Dvbbs.checkStr(id))
	UPDATE_User_Msg(Dvbbs.membername)
	Dvbbs.Dvbbs_Suc("<li>"+template.Strings(36))
End If
End Sub

'-------------------------------------------------------------------------------------------------------------
'显示错误信息
Sub Showerr()
Dim Show_Errmsg
	If ErrCodes<>"" Then 
		Show_Errmsg=Dvbbs.mainhtml(14)
		ErrCodes=Replace(ErrCodes,"{$color}",Dvbbs.mainSetting(1))
		Show_Errmsg=Replace(Show_Errmsg,"{$color}",Dvbbs.mainSetting(1))
		Show_Errmsg=Replace(Show_Errmsg,"{$errtitle}",Dvbbs.Forum_Info(0)&"-"&Dvbbs.Stats)
		Show_Errmsg=Replace(Show_Errmsg,"{$action}",Dvbbs.Stats)
		Show_Errmsg=Replace(Show_Errmsg,"{$ErrString}",ErrCodes)
	End If
	Response.write Show_Errmsg
End Sub

'用户好友下拉名单
Function OPTION_Friend()
DIM i
Sql="SELECT F_friend FROM Dv_Friend WHERE F_userid="&Dvbbs.userid&" ORDER BY F_addtime DESC"
Set Rs=Dvbbs.Execute(Sql)
If not Rs.eof Then
	SQL=Rs.GetRows(-1)
	Rs.Close:Set Rs=Nothing
End if
If IsArray(SQL) Then
	For i=0 To Ubound(SQL,2)
	OPTION_Friend=OPTION_Friend & "<OPTION value="""&SQL(0,i)&""">"&SQL(0,i)&"</OPTION> "
	Next
Else
	OPTION_Friend=""
End If
End Function

'黑名单验证
Function CHKHateName(name)
DIM Sql,Rs
CHKHateName=False
Sql="Select F_friend From Dv_Friend Where (F_userid="&Dvbbs.userid&" or F_username='"&name&"') And F_Mod=2"
Set Rs=Dvbbs.Execute(Sql)
If not Rs.eof Then
	Sql=Rs.GetString(,, ",", "", "")
	Rs.Close:Set Rs=Nothing
	If instr(Sql,name) or instr(Sql,Dvbbs.Membername) Then CHKHateName=True
End If
End Function

'更新用户短信通知信息（新短信条数||新短讯ID||发信人名）
Sub UPDATE_User_Msg(username)
	Dim msginfo,i,UP_UserInfo,newmsg
	newmsg=newincept(username)
	If newmsg>0 Then
		msginfo=newincept(username) & "||" & inceptid(1,username) & "||" & inceptid(2,username)
	Else
		msginfo="0||0||null"
	End If
	Dvbbs.execute("UPDATE [Dv_User] Set UserMsg='"&Dvbbs.CheckStr(msginfo)&"' WHERE username='"&Dvbbs.CheckStr(username)&"'")
	If username=Dvbbs.MemberName Then
		UP_UserInfo=Session(Dvbbs.CacheName & "UserID")
		UP_UserInfo(30)=msginfo
		Session(Dvbbs.CacheName & "UserID")=UP_UserInfo
	Else
		Call Dvbbs.NeedUpdateList(username,1)
	End If
End Sub

'统计留言
Function newincept(iusername)
Dim Rs
Rs=Dvbbs.execute("SELECT Count(id) FROM Dv_Message WHERE flag=0 And issend=1 And DelR=0 And incept='"& iusername &"'")
    newincept=Rs(0)
	Set Rs=nothing
	If isnull(newincept) Then newincept=0
End Function

Function inceptid(stype,iusername)
	Set Rs=Dvbbs.execute("SELECT top 1 id,sender FROM Dv_Message WHERE flag=0 And issend=1 And DelR=0 And incept='"& iusername &"'")
	If not rs.eof Then
		If stype=1 Then
			inceptid=Rs(0)
		Else
			inceptid=Rs(1)
		End If
	Else
		If stype=1 Then
			inceptid=0
		Else
			inceptid="null"
		End If
	End If
	Set Rs=nothing
End Function

Function Get_ForumCSS()
	Dim Sid
	sid = Request.Cookies("skin")("skinid_0")
	If Not IsNumeric(sid) Or sid = "" Then Sid=Application(Forum_CacheName & "_Dv_Setup")(17,0)
	Get_ForumCSS=Application(Forum_CacheName &"_Forum_CSS"&Sid)
End Function  

Function CheckID(CHECK_ID)
	Dim Delid,Fixid
	CheckID=True
	Delid=replace(CHECK_ID,"'","")
	Delid=replace(Delid,";","")
	Delid=replace(Delid,"--","")
	Delid=replace(Delid,")","")
	Fixid=replace(Delid,",","")
	Fixid=Trim(replace(fixid," ",""))
	If Delid="" or isnull(Delid) Then  CheckID=False
	If Not IsNumeric(fixid) Then CheckID=False
End Function

Function EncodeJS(str)
EncodeJS = Replace(Replace(Replace(Replace(Replace(str,chr(10),""),"\","\\"),"'","\'"),VbCrLf,"\n"),chr(13),"")
End Function

'发贴时用，为了减少入库量
Function Html2Ubb(str)
	If Str<>"" And Not IsNull(Str) Then
		Dim re,tmpstr
		Set re=new RegExp
		re.IgnoreCase =True
		re.Global=True
		re.Pattern = "(<br>)"
		Str = re.Replace(Str,"[br]")
		'If Dvbbs.Board_Setting(5)="0" Then 
		'	re.Pattern="<(.[^>]*)>"
		'	Str=re.Replace(Str,"")	
		'End If
		Str = Replace(Str, "[br]", "<br>")
		re.Pattern = "(&nbsp;)"
		Str = re.Replace(Str,Chr(9))
		re.Pattern="(>)("&vbNewLine&")(<)"
		Str=re.Replace(Str,"$1$3") 
		re.Pattern="(>)("&vbNewLine&vbNewLine&")(<)"
		Str=re.Replace(Str,"$1$3") 
		re.Pattern = "(<p>)"
		Str = re.Replace(Str,"")
		re.Pattern = "(<\/p>)"
		Str = re.Replace(Str,CHR(13) & CHR(10))
		re.Pattern = "(<STRONG>)"
		Str = re.Replace(Str,"<b>")
		re.Pattern = "(<\/STRONG>)"
		Str = re.Replace(Str,"</b>")
		re.Pattern ="(<TBODY>)"
		Str = re.Replace(Str,"")
		re.Pattern ="(<\/TBODY>)"
		Str = re.Replace(Str,"")
		Set Re=Nothing
		Html2Ubb = Str
	Else
		Html2Ubb = ""
	End If
End Function
%>