<%
'*************************************************
'函数名：gotTopic
'作  用：截字符串，汉字一个算两个字符，英文算一个字符
'参  数：str   ----原字符串
'       strlen ----截取长度
'返回值：截取后的字符串
'*************************************************
function gotTopic(str,strlen)
	if str="" then
		gotTopic=""
		exit function
	end if
	dim l,t,c, i
	str=replace(replace(replace(replace(str,"&nbsp;"," "),"&quot;",chr(34)),"&gt;",">"),"&lt;","<")
	l=len(str)
	t=0
	for i=1 to l
		c=Abs(Asc(Mid(str,i,1)))
		if c>255 then
			t=t+2
		else
			t=t+1
		end if
		if t>=strlen then
			gotTopic=left(str,i) & "…"
			exit for
		else
			gotTopic=str
		end if
	next
	gotTopic=replace(replace(replace(replace(gotTopic," ","&nbsp;"),chr(34),"&quot;"),">","&gt;"),"<","&lt;")
end function

'***********************************************
'函数名：JoinChar
'作  用：向地址中加入 ? 或 &
'参  数：strUrl  ----网址
'返回值：加了 ? 或 & 的网址
'pos=InStr(1,"abcdefg","cd") 
'则pos会返回3表示查找到并且位置为第三个字符开始。
'这就是“查找”的实现，而“查找下一个”功能的
'实现就是把当前位置作为起始位置继续查找。
'***********************************************
function JoinChar(strUrl)
	if strUrl="" then
		JoinChar=""
		exit function
	end if
	if InStr(strUrl,"?")<len(strUrl) then 
		if InStr(strUrl,"?")>1 then
			if InStr(strUrl,"&")<len(strUrl) then 
				JoinChar=strUrl & "&"
			else
				JoinChar=strUrl
			end if
		else
			JoinChar=strUrl & "?"
		end if
	else
		JoinChar=strUrl
	end if
end function

'***********************************************
'过程名：showpage
'作  用：显示“上一页 下一页”等信息
'参  数：sfilename  ----链接地址
'       totalnumber ----总数量
'       maxperpage  ----每页数量
'       ShowTotal   ----是否显示总数量
'       ShowAllPages ---是否用下拉列表显示所有页面以供跳转。有某些页面不能使用，否则会出现JS错误。
'       strUnit     ----计数单位
'***********************************************
sub showpage(sfilename,totalnumber,maxperpage,ShowTotal,ShowAllPages,strUnit)
	dim n, i,strTemp,strUrl
	if totalnumber mod maxperpage=0 then
    	n= totalnumber \ maxperpage
  	else
    	n= totalnumber \ maxperpage+1
  	end if
  	strTemp= "<table align='center'><form name='showpages' method='Post' action='" & sfilename & "'><tr><td>"
	if ShowTotal=true then 
		strTemp=strTemp & "共 <b>" & totalnumber & "</b> " & strUnit & "&nbsp;&nbsp;"
	end if
	strUrl=JoinChar(sfilename)
  	if CurrentPage<2 then
    		strTemp=strTemp & "首页 上一页&nbsp;"
  	else
    		strTemp=strTemp & "<a href='" & strUrl & "page=1'>首页</a>&nbsp;"
    		strTemp=strTemp & "<a href='" & strUrl & "page=" & (CurrentPage-1) & "'>上一页</a>&nbsp;"
  	end if

  	if n-currentpage<1 then
    		strTemp=strTemp & "下一页 尾页"
  	else
    		strTemp=strTemp & "<a href='" & strUrl & "page=" & (CurrentPage+1) & "'>下一页</a>&nbsp;"
    		strTemp=strTemp & "<a href='" & strUrl & "page=" & n & "'>尾页</a>"
  	end if
   	strTemp=strTemp & "&nbsp;页次：<strong><font color=red>" & CurrentPage & "</font>/" & n & "</strong>页 "
    strTemp=strTemp & "&nbsp;<b>" & maxperpage & "</b>" & strUnit & "/页"
	if ShowAllPages=True then
		strTemp=strTemp & "&nbsp;转到：<select name='page' size='1' onchange='javascript:submit()'>"   
    	for i = 1 to n   
    		strTemp=strTemp & "<option value='" & i & "'"
			if cint(CurrentPage)=cint(i) then strTemp=strTemp & " selected "
			strTemp=strTemp & ">第" & i & "页</option>"   
	    next
		strTemp=strTemp & "</select>"
	end if
	strTemp=strTemp & "</td></tr></form></table>"
	response.write strTemp
end sub

'********************************************
'函数名：IsValidEmail
'作  用：检查Email地址合法性
'参  数：email ----要检查的Email地址
'返回值：True  ----Email地址合法
'       False ----Email地址不合法
'********************************************
function IsValidEmail(email)
	dim names, name, i, c
	IsValidEmail = true
	names = Split(email, "@")
	if UBound(names) <> 1 then
	   IsValidEmail = false
	   exit function
	end if
	for each name in names
		if Len(name) <= 0 then
			IsValidEmail = false
    		exit function
		end if
		for i = 1 to Len(name)
		    c = Lcase(Mid(name, i, 1))
			if InStr("abcdefghijklmnopqrstuvwxyz_-.", c) <= 0 and not IsNumeric(c) then
		       IsValidEmail = false
		       exit function
		     end if
	   next
	   if Left(name, 1) = "." or Right(name, 1) = "." then
    	  IsValidEmail = false
	      exit function
	   end if
	next
	if InStr(names(1), ".") <= 0 then
		IsValidEmail = false
	   exit function
	end if
	i = Len(names(1)) - InStrRev(names(1), ".")
	if i <> 2 and i <> 3 then
	   IsValidEmail = false
	   exit function
	end if
	if InStr(email, "..") > 0 then
	   IsValidEmail = false
	end if
end function

'***************************************************
'函数名：IsObjInstalled
'作  用：检查组件是否已经安装
'参  数：strClassString ----组件名
'返回值：True  ----已经安装
'       False ----没有安装
'***************************************************
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

'**************************************************
'函数名：strLength
'作  用：求字符串长度。汉字算两个字符，英文算一个字符。
'参  数：str  ----要求长度的字符串
'返回值：字符串长度
'**************************************************
function strLength(str)
	ON ERROR RESUME NEXT
	dim WINNT_CHINESE
	WINNT_CHINESE    = (len("中国")=2)
	if WINNT_CHINESE then
        dim l,t,c
        dim i
        l=len(str)
        t=l
        for i=1 to l
        	c=asc(mid(str,i,1))
            if c<0 then c=c+65536
            if c>255 then
                t=t+1
            end if
        next
        strLength=t
    else 
        strLength=len(str)
    end if
    if err.number<>0 then err.clear
end function

'**************************************************
'函数名：strLeft
'作  用：截取左N个字符的字符串。汉字算一个字符，英文算半个字符。
'参  数：str,num  ----要求长度的字符串
'返回值：num长度的字符串
'**************************************************
function strLeft(str,num)
	ON ERROR RESUME NEXT
	dim WINNT_CHINESE
	WINNT_CHINESE    = (len("中国")=2)
	if WINNT_CHINESE then
        dim l,t,c
        dim i
        l=len(str)
        t=0
		numer=cint(num)
		steps=2
        for i=1 to l
        	c=asc(mid(str,i,1))
            if c<0 then c=c+65536
            if c>=0 and c<=255 then
			  if i<cint(numer) then
                t=t+1
				if t = steps then
					numer=numer+1
					steps=steps+2
				end if
			  end if
            end if
        next
		t=cint(num)+cint(t/2)
        strLeft=left(str,t)
    else 
        strLeft=left(str,cint(num))
    end if
    if err.number<>0 then err.clear
end Function

function isChar(str)
	dim l
	isChar=True
	l=len(str)
	for i=1 to l
		c=asc(mid(str,i,1))
		if c<0 then c=c+65536
		if c>=0 and c<=255 then
		Else
			isChar=false
		end if
	Next
end Function
'****************************************************
'函数名：SendMail
'作  用：用Jmail组件发送邮件
'参  数：ServerAddress  ----服务器地址
'        AddRecipient  ----收信人地址
'        Subject       ----主题
'        Body          ----信件内容
'        Sender        ----发信人地址
'****************************************************
function SendMail(MailServerAddress,AddRecipient,Subject,MailBody,Sender,SenderName,SenderPass)
	on error resume next

	Set jmail = Server.CreateObject("JMAIL.Message")   '建立发送邮件的对象
	jmail.silent = true    '屏蔽例外错误，返回FALSE跟TRUE两值j
	jmail.logging = true   '启用邮件日志
	jmail.Charset = "GB2312"     '邮件的文字编码为国标
	jmail.ContentType = "text/html"    '邮件的格式为HTML格式

	if err then
		SendMail= "没有安装JMail组件"
		err.clear
		exit function
	end if

	jmail.AddRecipient AddRecipient     '邮件收件人的地址
	jmail.From = Sender   '发件人的E-MAIL地址
	jmail.MailServerUserName = SenderName     '登录邮件服务器所需的用户名
	jmail.MailServerPassword = SenderPass     '登录邮件服务器所需的密码
	jmail.Subject = Subject    '邮件的标题 
	jmail.Body = MailBody      '邮件的内容
	jmail.Priority = 1      '邮件的紧急程序，1 为最快，5 为最慢， 3 为默认值
	jmail.Send(MailServerAddress)     '执行邮件发送（通过邮件服务器地址）
	jmail.Close()   '关闭对象

	Set JMail=nothing 
	if err then 
		SendMail=err.description
		err.clear
	else
		SendMail="OK"
	end if
end function

  
'****************************************************
'过程名：WriteErrMsg
'作  用：显示错误提示信息
'参  数：无
'****************************************************
sub WriteErrMsg()
	dim strErr
	strErr=strErr & "<html><head><title>错误信息</title><meta http-equiv='Content-Type' content='text/html; charset=gb2312'>" & vbcrlf
	strErr=strErr & "<link href='style.css' rel='stylesheet' type='text/css'></head><body>" & vbcrlf
	strErr=strErr & "<table cellpadding=2 cellspacing=2 border=0 width=400 class='border' align=center>" & vbcrlf
	strErr=strErr & "  <tr align='center'><td height='20' class='title'><strong>错误信息</strong></td></tr>" & vbcrlf
	strErr=strErr & "  <tr><td height='100' class='tdbg' valign='top'><b>产生错误的可能原因：</b><br>" & errmsg &"</td></tr>" & vbcrlf
	strErr=strErr & "  <tr align='center'><td class='title'><a href='javascript:history.go(-1)'>【返回】</a></td></tr>" & vbcrlf
	strErr=strErr & "</table>" & vbcrlf
	strErr=strErr & "</body></html>" & vbcrlf
	response.write strErr
end sub

'****************************************************
'过程名：WriteSuccessMsg
'作  用：显示成功提示信息
'参  数：无
'****************************************************
sub WriteSuccessMsg(SuccessMsg)
	dim strSuccess
	strSuccess=strSuccess & "<html><head><title>成功信息</title><meta http-equiv='Content-Type' content='text/html; charset=gb2312'>" & vbcrlf
	strSuccess=strSuccess & "<link href='style.css' rel='stylesheet' type='text/css'></head><body>" & vbcrlf
	strSuccess=strSuccess & "<table cellpadding=2 cellspacing=2 border=0 width=400 class='border' align=center>" & vbcrlf
	strSuccess=strSuccess & "  <tr align='center'><td height='20' class='title'><strong>恭喜你！</strong></td></tr>" & vbcrlf
	strSuccess=strSuccess & "  <tr><td height='100' class='tdbg' valign='top'><br>" & SuccessMsg &"</td></tr>" & vbcrlf
	strSuccess=strSuccess & "  <tr align='center'><td class='title'><a href='javascript:history.go(-1)'>【返回】</a></td></tr>" & vbcrlf
	strSuccess=strSuccess & "</table>" & vbcrlf
	strSuccess=strSuccess & "</body></html>" & vbcrlf
	response.write strSuccess
end sub


'****************************************************
'函数名：Encrypt
'作  用：简单字符串加密
'参  数：theNumber
'****************************************************
Function Encrypt(theNumber)
On Error Resume Next
Dim n, szEnc, t, HiN, LoN, i
n = CDbl((theNumber + 1570) ^ 2 - 7 * (theNumber + 1570) - 450)
If n < 0 Then szEnc = "R" Else szEnc = "J"
n = CStr(abs(n))
For i = 1 To Len(n) step 2
  t = Mid(n, i, 2)
  If Len(t) = 1 Then
   szEnc = szEnc & t
   Exit For
  End If
  HiN = (CInt(t) And 240) / 16
  LoN = CInt(t) And 15
  szEnc = szEnc & Chr(Asc("M") + HiN) & Chr(Asc("C") + LoN)
Next
Encrypt = szEnc
End Function


'****************************************************
'函数名：Decrypt
'作  用：简单字符串解密
'参  数：theNumber
'****************************************************
Function Decrypt(theNumber)
On Error Resume Next
Dim e, n, sign, t, HiN, LoN, NewN, i
e = theNumber
If Left(e, 1) = "R" Then sign = -1 Else sign = 1
e = Mid(e, 2)
NewN = ""
For i = 1 To Len(e) step 2
  t = Mid(e, i, 2)
  If Asc(t) >= Asc("0") And Asc(t) <= Asc("9") Then
   NewN = NewN & t
   Exit For
  End If
  HiN = Mid(t, 1, 1)
  LoN = Mid(t, 2, 1)
  HiN = (Asc(HiN) - Asc("M")) * 16
  LoN = Asc(LoN) - Asc("C")
  t = CStr(HiN Or LoN)
  If Len(t) = 1 Then t = "0" & t
  NewN = NewN & t
Next
e = CDbl(NewN) * sign
Decrypt = CLng((7 + sqr(49 - 4 * (-450 - e))) / 2 - 1570)
End Function


'****************************************************
'函数名：RoundEncode
'作  用：简单字符串加密
'参  数：strEncode
'****************************************************
Function RoundEncode(strEncode)   
  dim   i   
  dim   iChar   
  dim   strMid   
  strMid=""   
  for   i=1   to   len(strEncode)   
  if   i<>len(strEncode)   then   
  iChar=asc(mid(strEncode,i,1))+asc(mid(strEncode,i+1,1))   
  elseif   i=1   then   
  '长度为1的情况   
  iChar=asc(mid(strEncode,i,1))*2   
  else   
  '下面使用了strMid的第一位，是因为需要用加密后的第一位   
  iChar=asc(mid(strEncode,i,1))+asc(mid(strMid,1,1))   
  end   if   
  if   iChar>128   then   
  iChar=iChar-128   
  end   if   
  strMid=strMid   &   chr(iChar)   
  next   
  RoundEncode=strMid   
End function 

'****************************************************
'函数名：RoundEncode
'作  用：简单字符串解密
'参  数：strDecode
'****************************************************
Function RoundDecode(strDecode)   
  dim   i   
  dim   iChar   
  for   i=len(strDecode)   to   1   step   -1   
  if   i<>len(strDecode)   then   
  iChar=asc(mid(strDecode,i,1))-asc(mid(strDecode,i+1,1))   
  elseif   i=1   then   
  '长度为1的情况   
  iChar=asc(mid(strDecode,i,1))\2   
  else   
  iChar=asc(mid(strDecode,i,1))-asc(mid(strDecode,1,1))   
  end   if   
  if   iChar<0   then   
  iChar=iChar+128   
  end   if   
  strDecode=left(strDecode,i-1)   &   chr(iChar)   &   right(strDecode,len(strDecode)-i)   
  next   
  RoundDecode=strDecode   
End function   


Function GetTimeValue(DateString)

	Dim Temp,TempStr
	If isNull(DateString) or isTrueDate(DateString) = 0  Then Exit Function
	Temp = csTr(Year(DateString))
	If len(temp)<3 Then
		Temp = left(year(date),2) & temp
	End If
	TempStr = Temp
	
	Temp = csTr(month(DateString))
	If len(temp)<2 Then Temp = "0" & temp
	TempStr = TempStr & Temp

	Temp = csTr(day(DateString))
	If len(temp)<2 Then Temp = "0" & temp
	TempStr = TempStr & Temp

	Temp = csTr(Hour(DateString))
	If len(temp)<2 Then Temp = "0" & temp
	TempStr = TempStr & Temp

	Temp = csTr(Minute(DateString))
	If len(temp)<2 Then Temp = "0" & temp
	TempStr = TempStr & Temp

	Temp = csTr(Second(DateString))
	If len(temp)<2 Then Temp = "0" & temp
	TempStr = TempStr & Temp

	GetTimeValue = cCur(TempStr)

End Function

Function GetDateValue(DateString)

	Dim Temp,TempStr
	If isNull(DateString) or isTrueDate(DateString) = 0  Then Exit Function
	Temp = csTr(Year(DateString))
	If len(temp)<3 Then
		Temp = left(year(date),2) & temp
	End If
	TempStr = Temp & "."
	
	Temp = csTr(month(DateString))
	If len(temp)<2 Then Temp = "0" & temp
	TempStr = TempStr & Temp & "."

	Temp = csTr(day(DateString))
	If len(temp)<2 Then Temp = "0" & temp
	TempStr = TempStr & Temp

	GetDateValue = TempStr

End Function

Function GetDateValue_Diary(DateString)
	If isNull(DateString) or isTrueDate(DateString) = 0  Then Exit Function
	Mon=csTr(Month(DateString))
	If len(Mon)<2 Then Mon = "0" & Mon

	Days=csTr(Day(DateString))
	If len(Days)<2 Then Days = "0" & Days

	hou=csTr(hour(DateString))
	If len(hou)<2 Then hou = "0" & hou

	min=csTr(minute(DateString))
	If len(min)<2 Then min = "0" & min

	Sec=csTr(Second(DateString))
	If len(Sec)<2 Then Sec = "0" & Sec

	GetDateValue_Diary = csTr(Year(DateString))&"-"&Mon&"-"&Days&" "&hou&":"&min&":"&Sec
End Function

'用vbscript模拟javascript中的gettime()
Function getTime()   
  Dim tt: tt = Timer()   
  Dim nt: nt = Now()   
  Dim tp: tp = DateDiff("s", "1970-01-01 08:00:00", nt)    '秒   
  tp = tp & Int((CDbl(tt) - DateDiff("s", Date(), nt)) * 1000)    '毫秒   
  getTime = tp   
End Function 

'将200711271021转换成    '07/11/27 10:21时间格式
Function getListTime(DateString)   
  Dim nYear,nMonth,nDay,nHour,nMinute
  If Len(DateString)<12 Then
	  getListTime=Now()
  else
	  nYear=mid(DateString,3,2)
	  If Len(nYear)<4 Then nYear=year(date)
	  nMonth=mid(DateString,5,2)
	  If Len(nMonth)<2 Then nMonth=Month(date)
	  nDay=mid(DateString,7,2)
	  If Len(nDay)<2 Then nDay=Month(date)
	  nHour=mid(DateString,9,2)
	  If Len(nHour)<2 Then nHour=Hour(now())
	  nMinute=mid(DateString,11,2)
	  If Len(nMinute)<2 Then nMinute=Hour(now())

	  getListTime=nYear&"/"&nMonth&"/"&nDay&" "&nHour&":"&nMinute
  End if
End Function 

Rem 为VBScript的isDate缺陷而编写的函数,用on error resume next也拦不住
Function isTrueDate(TStr)

	Dim T
	T = TStr
	T = Replace(Replace(Replace(Replace(Replace(Replace(Replace(T,"年","-"),"月","-"),"日"," "),"上午"," "),"下午"," "),"  "," "),"  "," ")
	
	Dim N1,N2
	N1 = inStr(T,"-")
	If N1>0 Then N2 = inStrRev(T,"-")
	If N1 = N2 and N1 >0 Then
		isTrueDate = 0
		Exit Function
	End If

	N1 = inStr(T,":")
	If N1>0 Then N2 = inStrRev(T,"-")
	If N1 = N2 and N1 >0 Then
		isTrueDate = 0
		Exit Function
	End If

	If isDate(TStr) Then
		isTrueDate = 1
	Else
		isTrueDate = 0
	End If

End Function

Function UBB_FiltrateBadWords(tempStr)

	Dim re
	Set re = New RegExp
	re.Global = True
	re.IgnoreCase = True

	Dim Str
	Str = tempStr
	Dim FiltrateBadWordString_Temp,i,Temp_N
	FiltrateBadWordString_Temp = split(FiltrateBadWordString, "|")
	Temp_N = ubound(FiltrateBadWordString_Temp)
	For i = 0 to Temp_N
		'Str = Replace(Str, FiltrateBadWordString_Temp(i), string(len(FiltrateBadWordString_Temp(i)),"*"), 1,-1,0)
		re.Pattern="(" & FiltrateBadWordString_Temp(i) & ")"
		Str=re.Replace(Str,string(len(FiltrateBadWordString_Temp(i)),"*"))
	Next
	Set Re = Nothing
	UBB_FiltrateBadWords = Str

End Function



'*******************************************************************************************************得到用户等级
Function getdjinfo(id,user)
	If user<>"" then
		set userdj=conn.execute("select * from djcount where huiyuan='"&replace(user,"'","")&"' and onlinetime>0")
		if not (userdj.bof and userdj.eof) then
		  select case cint(id)
			case 1
				getdjinfo=int((sqr(255+(20*cint(userdj("onlinetime"))))-15)/10)
			case 2
				getdjinfo=cint(userdj("onlinetime"))
			case 3
				currentdj=int((sqr(255+(20*cint(userdj("onlinetime"))))-15)/10)+1
				getdjinfo=5*currentdj*currentdj+15*currentdj-cint(userdj("onlinetime"))
			case else
				getdjinfo=0
		  end select
		else
		  select case cint(id)
			case 1
				getdjinfo=0
			case 2
				getdjinfo=0
			case 3
				getdjinfo=20
			case else
				getdjinfo=0
		  end select
		end If
	Else
		getdjinfo=0
	End if
End Function
Function getdjico(user)
  getdjico=""
  id=getdjinfo(1,user)
  if CInt(id) >= 0 Then
	If Len(id) < 2 Then id = "0" & cstr(id)
	getdjico=getdjico & "<img align=absmiddle src=http://www.hongdou999.com/blog/i/uc/level/d0"&id&".gif alt='等级："&getdjinfo(1,user)&vbcrlf&"在线时长："&getdjinfo(2,user)&"小时"&vbcrlf&"剩余升级时间："&getdjinfo(3,user)&"小时'>"
  end if
End Function
'*************************/////////得到用户等级



'*******************************************************************************************************
Function getIcon(huiyuan)
	sql_t="select vip,xb from huiyuan where huiyuan='"&huiyuan&"'"
	set rs_t=server.createobject("adodb.recordset")
	rs_t.open sql_t,conn,1,1
	If Not (rs_t.bof And rs_t.eof) Then
		If rs_t("xb")="男" Then
			xbtype="1"
			xbimg="<img src='http://www.hongdou999.com/images/grade/man.gif'  border=0/>&nbsp;"
		Else
			xbtype="2"
			xbimg="<img src='http://www.hongdou999.com/images/grade/woman.gif'  border=0/>&nbsp;"
		End If
		
		select case cint(rs_t("vip"))
		case 0
			myalt="普通会员"
		case 1
			myalt="银牌VIP会员"
		case 2
			myalt="金牌VIP会员"
		case 3
			myalt="蓝钻VIP会员"
		case 4
			myalt="皇冠贵族"
		case else
			myalt=""
		end Select

		getIcon = xbimg & "<a href='http://www.hongdou999.com/help/vip.asp' target='_blank'><img alt="&myalt&" src=/images/grade/1" & (cint(rs_t("vip"))+1) & ".gif border=0 align=absmiddle></a>&nbsp;"
	Else
		getIcon=""
	End If
	rs_t.close
	Set rs_t=nothing
End Function

'*************************************************************************首页调用，不闪动
Function getIcon_index(huiyuan)
	sql_t="select vip,xb from huiyuan where huiyuan='"&huiyuan&"'"
	set rs_t=server.createobject("adodb.recordset")
	rs_t.open sql_t,conn,1,1
	If Not (rs_t.bof And rs_t.eof) Then
		If rs_t("xb")="男" Then
			xbtype="1"
			xbimg="<img src='http://www.hongdou999.com/images/grade/man.gif'  border=0/>&nbsp;"
		Else
			xbtype="2"
			xbimg="<img src='http://www.hongdou999.com/images/grade/woman.gif'  border=0/>&nbsp;"
		End If
		
		select case cint(rs_t("vip"))
		case 0
			myalt="普通会员"
		case 1
			myalt="银牌VIP会员"
		case 2
			myalt="金牌VIP会员"
		case 3
			myalt="蓝钻VIP会员"
		case 4
			myalt="皇冠贵族"
		case else
			myalt=""
		end Select

		getIcon_index = xbimg & "<a href='http://www.hongdou999.com/help/vip.asp' target='_blank'><img alt="&myalt&" src=/images/grade/1" & (cint(rs_t("vip"))+1) & "_i.gif border=0 align=absmiddle></a>&nbsp;"
	Else
		getIcon_index=""
	End If
	rs_t.close
	Set rs_t=nothing
End Function


Function getIcon_noxb(huiyuan)
	sql_t="select vip,xb from huiyuan where huiyuan='"&huiyuan&"'"
	set rs_t=server.createobject("adodb.recordset")
	rs_t.open sql_t,conn,1,1
	If Not (rs_t.bof And rs_t.eof) Then
		If rs_t("xb")="男" Then
			xbtype="1"
		Else
			xbtype="2"
		End If
		
		select case cint(rs_t("vip"))
		case 0
			myalt="普通会员"
		case 1
			myalt="银牌VIP会员"
		case 2
			myalt="金牌VIP会员"
		case 3
			myalt="蓝钻VIP会员"
		case 4
			myalt="皇冠贵族"
		case else
			myalt=""
		end Select

		getIcon_noxb = "<a href='http://www.hongdou999.com/help/vip.asp' target='_blank'><img alt="&myalt&" src=http://www.hongdou999.com/images/grade/1" & (cint(rs_t("vip"))+1) & ".gif border=0 align=absmiddle></a>&nbsp;"
	Else
		getIcon_noxb=""
	End If
	rs_t.close
	Set rs_t=nothing
End Function

'*************************************************************************首页调用，不闪动
Function getIcon_noxb_index(huiyuan)
	sql_t="select vip,xb from huiyuan where huiyuan='"&huiyuan&"'"
	set rs_t=server.createobject("adodb.recordset")
	rs_t.open sql_t,conn,1,1
	If Not (rs_t.bof And rs_t.eof) Then
		If rs_t("xb")="男" Then
			xbtype="1"
		Else
			xbtype="2"
		End If
		
		select case cint(rs_t("vip"))
		case 0
			myalt="普通会员"
		case 1
			myalt="银牌VIP会员"
		case 2
			myalt="金牌VIP会员"
		case 3
			myalt="蓝钻VIP会员"
		case 4
			myalt="皇冠贵族"
		case else
			myalt=""
		end Select

		getIcon_noxb_index = "<a href='http://www.hongdou999.com/help/vip.asp' target='_blank'><img alt="&myalt&" src=http://www.hongdou999.com/images/grade/1" & (cint(rs_t("vip"))+1) & "_i.gif border=0 align=absmiddle></a>&nbsp;"
	Else
		getIcon_noxb_index=""
	End If
	rs_t.close
	Set rs_t=nothing
End Function

Function getSex(huiyuan)
	sql_t="select xb from huiyuan where huiyuan='"&huiyuan&"'"
	set rs_t=server.createobject("adodb.recordset")
	rs_t.open sql_t,conn,1,1
	If Not (rs_t.bof And rs_t.eof) Then
		If rs_t("xb")="男" Then
			xbimg="<img src='http://www.hongdou999.com/images/grade/man.gif'  border=0/>&nbsp;"
		Else
			xbimg="<img src='http://www.hongdou999.com/images/grade/woman.gif'  border=0/>&nbsp;"
		End If
		getSex = xbimg
	Else
		getSex=""
	End If
	rs_t.close
	Set rs_t=nothing
End Function

Function getvipinfo(vip)
	select case cint(vip)
	case 0
		getvipinfo="普通会员"
	case 1
		getvipinfo="银牌VIP会员"
	case 2
		getvipinfo="金牌VIP会员"
	case 3
		getvipinfo="蓝钻VIP会员"
	case 4
		getvipinfo="皇冠贵族"
	case else
		myalt=""
	end Select
End Function

Function getstar(sp,sf,hy,xl,sr)
	Dim starcount
	If CInt(sp)=2 Then sp=0
	If CInt(sf)=2 Then sf=0
	If CInt(hy)=2 Then hy=0
	If CInt(xl)=2 Then xl=0
	If CInt(sr)=2 Then sr=0
	starcount=CInt(sp)+CInt(sf)+CInt(hy)+CInt(xl)+CInt(sr)
	For i=1 To starcount
		getstar = getstar & "<IMG alt=身份认证星级："&CStr(starcount)&"星 src='http://www.hongdou999.com/images/sfz_x.gif' align=absMiddle border=0>"
	Next
	'For i=1 To 5-starcount
		'getstar = getstar & "<IMG alt=身份认证星级："&CStr(starcount)&"星 src='/images/sfz_hx.gif' align=absMiddle border=0>"
	'Next
	If CInt(starcount)=0 Then getstar=getstar & " (没有星级)"
End Function

Function getstar_main(sp,sf,hy,xl,sr)
	Dim starcount
	If CInt(sp)=2 Then sp=0
	If CInt(sf)=2 Then sf=0
	If CInt(hy)=2 Then hy=0
	If CInt(xl)=2 Then xl=0
	If CInt(sr)=2 Then sr=0
	starcount=CInt(sp)+CInt(sf)+CInt(hy)+CInt(xl)+CInt(sr)
	getstar_main = "("
	For i=1 To starcount
		getstar_main = getstar_main & "<IMG alt=身份认证星级："&CStr(starcount)&"星 src='http://www.hongdou999.com/images/sfz_x.gif' align=absMiddle border=0>"
	Next
	getstar_main = getstar_main &")"
	'For i=1 To 5-starcount
		'getstar = getstar & "<IMG alt=身份认证星级："&CStr(starcount)&"星 src='/images/sfz_hx.gif' align=absMiddle border=0>"
	'Next
	If CInt(starcount)=0 Then getstar_main=""
End Function

Function getzt(zt)
	  select case cint(zt)
		case 0
			getzt="未通过验证"
		case 1
			getzt="征友进行中"
		case 2
			getzt="被锁定"
		case 3
			getzt="正在约会中"
		case 4
			getzt="关闭档案"
		case else
			getzt="参数错误"
	  end select
End Function



Function getlastLogin(adate)    '取得最后登陆时间 格式：1天前
	If IsDate(adate) Then
		temp=DateDiff("d",CDate(adate),Date())
		If abs(temp)>90 Then
			getlastLogin="三个月前"
		ElseIf abs(temp)>30 Then
			getlastLogin="一个月前"
		ElseIf abs(temp)>=1 Then
			getlastLogin=temp&"天前"
		Else
			temp2=DateDiff("h",CDate(adate),now())
			If abs(temp2)>=1 Then
				getlastLogin=temp2&"小时前"
			Else
				getlastLogin="刚刚下线"
			End if
		End if
	Else
		getlastLogin="未知"
	End if
End Function



Function getUserValue(str,val)
	  select case trim(str)
		case "tx"
			select case cint(val)
				case 1
					getUserValue="清瘦"
				case 2
					getUserValue="苗条"
				case 3
					getUserValue="中等"
				case 4
					getUserValue="健壮"
				case 5
					getUserValue="略胖"
				case 6
					getUserValue="匀称"
				case 7
					getUserValue="瘦小"
				case 8
					getUserValue="矮胖"
				case 9
					getUserValue="大个"
				case 10
					getUserValue="肥胖"
				case 11
					getUserValue="性感"
				case else
					getUserValue="未知"
			end select
		case "clothing"
			select case cint(val)
				case 1
					getUserValue="休闲"
				case 2
					getUserValue="职业"
				case 3
					getUserValue="时尚"
				case else
					getUserValue="未知"
			end select
		case "star"
			select case cint(val)
				case 1
					getUserValue="魔羯座"
				case 2
					getUserValue="水瓶座"
				case 3
					getUserValue="双鱼座"
				case 4
					getUserValue="白羊座"
				case 5
					getUserValue="金牛座"
				case 6
					getUserValue="双子座"
				case 7
					getUserValue="巨蟹座"
				case 8
					getUserValue="狮子座"
				case 9
					getUserValue="处女座"
				case 10
					getUserValue="天秤座"
				case 11
					getUserValue="天蝎座"
				case 12
					getUserValue="射手座"
				case else
					getUserValue="未知"
			end select
		case "blood"
			select case cint(val)
				case 1
					getUserValue="A"
				case 2
					getUserValue="B"
				case 3
					getUserValue="AB"
				case 4
					getUserValue="O"
				case else
					getUserValue="其他或未知"
			end select
		case "zongjiao"
			select case cint(val)
				case 1
					getUserValue="无神论者"
				case 2
					getUserValue="佛教"
				case 3
					getUserValue="基督教"
				case 4
					getUserValue="道教"
				case 5
					getUserValue="伊斯兰教"
				case 6
					getUserValue="天主教"
				case 7
					getUserValue="有神论者"
				case else
					getUserValue="其他"
			end select
		case "zfzk"
			select case cint(val)
				case 1
					getUserValue="有婚房"
				case 2
					getUserValue="有能力购房"
				case 3
					getUserValue="无婚房"
				case 4
					getUserValue="无婚房但可解决"
				case 5
					getUserValue="无婚房希望对方解决"
				case 6
					getUserValue="无婚房希望双方解决"
				case else
					getUserValue="其他"
			end Select
		Case "gcqk"
			select case cint(val)
				case 1
					getUserValue="汽车"
				case 2
					getUserValue="中档汽车"
				case 3
					getUserValue="高档汽车"
				case 4
					getUserValue="有能力购汽车"
				case else
					getUserValue="其他"
			end Select
		Case "xl"
			select case cint(val)
				case 1
					getUserValue="初中及以下"
				case 2
					getUserValue="高中或中专"
				case 3
					getUserValue="大专"
				case 4
					getUserValue="本科"
				case 5
					getUserValue="硕士"
				case 6
					getUserValue="博士及以上"
				case else
					getUserValue="其他"
			end Select
		Case "field"
			select case cint(val)
				case 1
					getUserValue="计算机/互联网"
				case 2
					getUserValue="邮电/通讯"
				case 3
					getUserValue="银行/金融/保险/证券"
				case 4
					getUserValue="建筑/房地产"
				case 5
					getUserValue="商业/零售/批发"
				case 6
					getUserValue="影视/娱乐/体育"
				case 7
					getUserValue="艺术/音乐/舞蹈"
				case 8
					getUserValue="广告/媒体/出版"
				case 9
					getUserValue="美容/服装"
				case 10
					getUserValue="旅游/运输"
				case 11
					getUserValue="教育/培训/科研"
				case 12
					getUserValue="制造/化工/能源"
				case 13
					getUserValue="服务/宾馆/餐饮"
				case 14
					getUserValue="医疗/保健"
				case 15
					getUserValue="司法/律师/咨询"
				case 16
					getUserValue="宠物/公益组织"
				case 17
					getUserValue="警察/军人"
				case 18
					getUserValue="国家机构/机关"
				case 19
					getUserValue="农业"
				case 20
					getUserValue="在校学生"
				case else
					getUserValue="其他"
			end Select
		Case "zy"
			select case cint(val)
				case 1
					getUserValue="企业管理人员"
				case 2
					getUserValue="专家/教授"
				case 3
					getUserValue="工程/技术人员"
				case 4
					getUserValue="市场/销售人员"
				case 5
					getUserValue="行政人员/文职秘书"
				case 6
					getUserValue="普通职员"
				case 7
					getUserValue="机关干部/公务人员"
				case 8
					getUserValue="艺术家/演员"
				case 9
					getUserValue="教师"
				case 10
					getUserValue="工人"
				case 11
					getUserValue="农民"
				case 12
					getUserValue="军人"
				case 13
					getUserValue="学生"
				case 14
					getUserValue="自由职业者"
				case 15
					getUserValue="离/退休人员"
				case 16
					getUserValue="失业/无业"
				case else
					getUserValue="其他"
			end Select
		Case "ysr"
			select case cint(val)
				case 1
					getUserValue="600元以下"
				case 2
					getUserValue="600-799元"
				case 3
					getUserValue="800-999元"
				case 4
					getUserValue="1000-1499元"
				case 5
					getUserValue="1500-1999元"
				case 6
					getUserValue="2000-2999元"
				case 7
					getUserValue="3000-3999元"
				case 8
					getUserValue="4000-4999元"
				case 9
					getUserValue="5000-5999元"
				case 10
					getUserValue="6000-6999元"
				case 11
					getUserValue="7000-9999元"
				case 12
					getUserValue="10000-19999元"
				case 13
					getUserValue="20000元以上"
				case else
					getUserValue="未知"
			end Select
		Case "isxy"
			select case cint(val)
				case 1
					getUserValue="不吸"
				case 2
					getUserValue="偶尔吸"
				case 3
					getUserValue="一天一包"
				case 4
					getUserValue="有烟就吸"
				case 5
					getUserValue="正在戒烟"
				case 6
					getUserValue="已经戒了"
				case else
					getUserValue="未知"
			end Select
		Case "ishj"
			select case cint(val)
				case 1
					getUserValue="滴酒不沾"
				case 2
					getUserValue="有时喝一些"
				case 3
					getUserValue="喜欢来两杯"
				case 4
					getUserValue="好酒量，天天喝"
				case 5
					getUserValue="正在戒酒"
				case 6
					getUserValue="已经戒了"
				case else
					getUserValue="未知"
			end Select
		Case "hz"
			select case cint(val)
				case 1
					getUserValue="不想透露"
				case 2
					getUserValue="没有"
				case 3
					getUserValue="有，我们住在一起"
				case 4
					getUserValue="有，我们偶尔一起住"
				case 5
					getUserValue="我有孩子，但不在身边"
				case else
					getUserValue="未知"
			end Select
		Case "jtcy"
			select case cint(val)
				case 1
					getUserValue="独生子女"
				case 2
					getUserValue="兄弟姐妹1人"
				case 3
					getUserValue="兄弟姐妹2人"
				case 4
					getUserValue="兄弟姐妹3人"
				case 5
					getUserValue="兄弟姐妹4人"
				case 6
					getUserValue="兄弟姐妹5人"
				case 7
					getUserValue="兄弟姐妹6人"
				case 8
					getUserValue="兄弟姐妹7人"
				case else
					getUserValue="未知"
			end Select
		Case "kind"
			select case cint(val)
				case 1
					getUserValue="都可以"
				case 2
					getUserValue="友情"
				case 3
					getUserValue="爱情"
				case 4
					getUserValue="正式征婚"
				case 5
					getUserValue="思想交流"
				case else
					getUserValue="未知"
			end Select
		Case "hyzk"
			select case cint(val)
				case 1
					getUserValue="未婚"
				case 2
					getUserValue="已婚"
				case 3
					getUserValue="离异有子女"
				case 4
					getUserValue="离异无子女"
				case 5
					getUserValue="丧偶有子女"
				case 6
					getUserValue="丧偶无子女"
				Case else
					getUserValue="保密"
			end Select
	  end select
End Function


'HTML转化   用来反编译用server.Urlencode加密的地址
function urldecode(encodestr) 
	newstr="" 
	havechar=false 
	lastchar="" 
	for i=1 to len(encodestr) 
		char_c=mid(encodestr,i,1) 
		if char_c="+" then 
			newstr=newstr & " " 
		elseif char_c="%" then 
			next_1_c=mid(encodestr,i+1,2) 
			next_1_num=cint("&H" & next_1_c) 
			if havechar then 
				havechar=false 
				newstr=newstr & chr(cint("&H" & lastchar & next_1_c)) 
			else 
				if abs(next_1_num)<=127 then 
					newstr=newstr & chr(next_1_num) 
				else 
					havechar=true 
					lastchar=next_1_c 
				end if 
			end if 
			i=i+2 
		else 
			newstr=newstr & char_c 
		end if 
	next 
	urldecode=newstr 
end Function

function FilterName(uStr)

	If InStr(uStr,"@163.com")>0 Then uStr=Replace(uStr,"@163.com","_901")
	If InStr(uStr,"@qq.com")>0 Then uStr=Replace(uStr,"@qq.com","_902")
	If InStr(uStr,"@126.com")>0 Then uStr=Replace(uStr,"@126.com","_903")
	If InStr(uStr,"@yahoo.cn")>0 Then uStr=Replace(uStr,"@yahoo.cn","_904")
	If InStr(uStr,"@yahoo.com.cn")>0 Then uStr=Replace(uStr,"@yahoo.com.cn","_905")
	If InStr(uStr,"@sina.com")>0 Then uStr=Replace(uStr,"@sina.com","_906")
	If InStr(uStr,"@21cn.com")>0 Then uStr=Replace(uStr,"@21cn.com","_907")
	If InStr(uStr,"@sohu.com")>0 Then uStr=Replace(uStr,"@sohu.com","_908")
	If InStr(uStr,"@tom.com")>0 Then uStr=Replace(uStr,"@tom.com","_909")
	If InStr(uStr,"@gmail.com")>0 Then uStr=Replace(uStr,"@gmail.com","_910")
	If InStr(uStr,"@hotmail.com")>0 Then uStr=Replace(uStr,"@hotmail.com","_911")
	If InStr(uStr,"@msn.com")>0 Then uStr=Replace(uStr,"@msn.com","_912")

	If InStr(uStr,".com")>0 Then uStr=Replace(uStr,".com","_990")
	If InStr(uStr,".com.cn")>0 Then uStr=Replace(uStr,".com","_991")
	If InStr(uStr,".cn")>0 Then uStr=Replace(uStr,".cn","_992")
	If InStr(uStr,".net")>0 Then uStr=Replace(uStr,".net","_993")
	If InStr(uStr,".net.cn")>0 Then uStr=Replace(uStr,".net.cn","_994")
	If InStr(uStr,".org")>0 Then uStr=Replace(uStr,".org","_995")
	If InStr(uStr,".org.cn")>0 Then uStr=Replace(uStr,".org.cn","_996")
	If InStr(uStr,".gov")>0 Then uStr=Replace(uStr,".gov","_997")
	If InStr(uStr,".gov.cn")>0 Then uStr=Replace(uStr,".gov.cn","_998")
	If InStr(uStr,".cc")>0 Then uStr=Replace(uStr,".cc","_999")

	uStr=Replace(uStr,"@","__")
	FilterName=uStr	
end Function

function ResetName(uStr)

	If InStr(uStr,"_901")>0 Then uStr=Replace(uStr,"_901","@163.com")
	If InStr(uStr,"_902")>0 Then uStr=Replace(uStr,"_902","@qq.com")
	If InStr(uStr,"_903")>0 Then uStr=Replace(uStr,"_903","@126.com")
	If InStr(uStr,"_904")>0 Then uStr=Replace(uStr,"_904","@yahoo.cn")
	If InStr(uStr,"_905")>0 Then uStr=Replace(uStr,"_905","@yahoo.com.cn")
	If InStr(uStr,"_906")>0 Then uStr=Replace(uStr,"_906","@sina.com")
	If InStr(uStr,"_907")>0 Then uStr=Replace(uStr,"_907","@21cn.com")
	If InStr(uStr,"_908")>0 Then uStr=Replace(uStr,"_908","@sohu.com")
	If InStr(uStr,"_909")>0 Then uStr=Replace(uStr,"_909","@tom.com")
	If InStr(uStr,"_910")>0 Then uStr=Replace(uStr,"_910","@gmail.com")
	If InStr(uStr,"_911")>0 Then uStr=Replace(uStr,"_911","@hotmail.com")
	If InStr(uStr,"_912")>0 Then uStr=Replace(uStr,"_912","@msn.com")

	If InStr(uStr,"_990")>0 Then uStr=Replace(uStr,"_990",".com")
	If InStr(uStr,"_991")>0 Then uStr=Replace(uStr,"_991",".com")
	If InStr(uStr,"_992")>0 Then uStr=Replace(uStr,"_992",".cn")
	If InStr(uStr,"_993")>0 Then uStr=Replace(uStr,"_993",".net")
	If InStr(uStr,"_994")>0 Then uStr=Replace(uStr,"_994",".net.cn")
	If InStr(uStr,"_995")>0 Then uStr=Replace(uStr,"_995",".org")
	If InStr(uStr,"_996")>0 Then uStr=Replace(uStr,"_996",".org.cn")
	If InStr(uStr,"_997")>0 Then uStr=Replace(uStr,"_997",".gov")
	If InStr(uStr,"_998")>0 Then uStr=Replace(uStr,"_998",".gov.cn")
	If InStr(uStr,"_999")>0 Then uStr=Replace(uStr,"_999",".cc")

	uStr=Replace(uStr,"__","@")
	ResetName=uStr	
end Function

'****************************************************
%>
