<%
'***************************************************
'检查组件是否已经安装
'***************************************************
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
'*************************************************
'函数名：DoDelslhtml
'作  用：删除指定路径和名称的文件
'参  数：htmlname ----文件的路径和名称
'*************************************************
Sub DoDelslhtml(htmlname)
	On Error Resume Next
	Set fso = Server.CreateObject("Scripting.FileSystemObject")
	servermap=server.MapPath("..")
	servermap=servermap&"\"&htmlname
	FSO.DeleteFile(servermap)
	Set FSO = Nothing
End Sub

'**************************************************
'函数名：Alert
'作  用：操作过程提示并决定去向 
'**************************************************
Function Alert(message,gourl) 
    message = replace(message,"'","\'")
    If gourl="-1" then
        Response.Write ("<script language=javascript>alert('" & message & "');history.go(-1)</script>")
    ElseIf gourl="-2" then
        Response.Write ("<script language=javascript>alert('" & message & "');history.go(-2)</script>")
    ElseIf gourl="Close" then
		Response.Write ("<script language=javascript>alert('" & message & "');window.opener=null;window.close();</script>")
	Else
        Response.Write ("<script language=javascript>alert('" & message & "');location='" & gourl &"'</script>")
    End If
    Response.End()
End Function

'*************************************************
'函数名：ReplaceBadChar
'作  用：替换一些特殊字符，主要用于登录和统计阅读次数
'参  数：strChar ----要处理的字符串
'*************************************************
Function ReplaceBadChar(strChar)
    If strChar = "" Or IsNull(strChar) Then
        ReplaceBadChar = ""
        Exit Function
    End If
    Dim strBadChar, arrBadChar, tempChar, i
    strBadChar = "+,',%,^,&,?,(,),<,>,[,],{,},/,\,;,:," & Chr(34) & "," & Chr(0) & ",--"
    arrBadChar = Split(strBadChar, ",")
    tempChar = strChar
    For i = 0 To UBound(arrBadChar)
        tempChar = Replace(tempChar, arrBadChar(i), "")
    Next
    tempChar = Replace(tempChar, "@@", "@")
    ReplaceBadChar = tempChar
End Function

'*************************************************
'函数名：ReplaceConstChar
'作  用：替换一些特殊字符，用于后台基本参数设置
'参  数：strChar ----要处理的字符串
'*************************************************
Function ReplaceConstChar(strChar)
    If strChar = "" Or IsNull(strChar) Then
        ReplaceConstChar = ""
        Exit Function
    End If
    Dim strBadChar, arrBadChar, tempChar, i
    strBadChar = "+,',%,^,&,?,(,),<,>,[,],{,},," & Chr(0) & ""
    arrBadChar = Split(strBadChar, ",")
    tempChar = strChar
    For i = 0 To UBound(arrBadChar)
        tempChar = Replace(tempChar, arrBadChar(i), "")
    Next
    tempChar = Replace(tempChar, "@@", "@")
    ReplaceConstChar = tempChar
End Function

'*************************************************
'函数名：StrLen
'作  用：计算字符串长度
'参  数：str ----要处理的字符串
'*************************************************
function StrLen(Str)
  if Str="" or isnull(Str) then
    StrLen=0
    exit function
  else
    dim regex
    set regex=new regexp
    regEx.Pattern ="[^\x00-\xff]"
    regex.Global =true
    Str=regEx.replace(Str,"^^")
    set regex=nothing
    StrLen=len(Str)
  end if
end Function

'*************************************************
'函数名：GetLen
'作  用：计算字符串长度
'参  数：str ----要处理的字符串
'*************************************************
Function GetLen(str)
    Dim l, t, c, 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
    Next
    GetLen = t
    End Function

'*************************************************
'函数名：StrLeft
'作  用：整齐地截取指定长度字符串，汉字一个算两个字符
'        英文算一个字符，超过用...省略
'参  数：str ----要处理的字符串
'        StrLen－截取的长度
'*************************************************
function StrLeft(Str,StrLen)
  dim L,T,I,C
  if Str="" then
    StrLeft=""
    exit function
  end if
  Str=Replace(Replace(Replace(Replace(Str,"&nbsp;"," "),"&quot;",Chr(34)),"&gt;",">"),"&lt;","<")
  L=Len(Str)
  T=0
  for i=1 to L
    C=Abs(AscW(Mid(Str,i,1)))
    if C>255 then
      T=T+2
    else
      T=T+1
    end if
    if T>=StrLen then
      StrLeft=left(str,i)&"..."
      exit for
    else
      StrLeft=Str
    end if
  next
  StrLeft=Replace(Replace(Replace(replace(StrLeft," ","&nbsp;"),Chr(34),"&quot;"),">","&gt;"),"<","&lt;")
end Function

'*************************************************
'函数名：CutStr
'作  用：整齐地截取指定长度字符串，汉字一个算两个字符
'        英文算一个字符
'参  数：str ----要处理的字符串
'        StrLen－截取的长度，0不截取
'        Other－超过限定代替的字符
'*************************************************
Function CutStr(Str,StrLen,Other)
  dim L,T,I,C
  if Str="" then
    CutStr=""
    exit function
  end if
  Str=Replace(Replace(Replace(Replace(Str,"&nbsp;"," "),"&quot;",Chr(34)),"&gt;",">"),"&lt;","<")
  L=Len(Str)
  T=0
  for i=1 to L
    C=Abs(AscW(Mid(Str,i,1)))
    if C>255 then
      T=T+2
    else
      T=T+1
    end if
    if T>=StrLen And StrLen>0 then
      CutStr=left(str,i)&Other
      exit for
    else
      CutStr=Str
    end if
  next
  'CutStr=Replace(Replace(Replace(replace(CutStr," ","&nbsp;"),Chr(34),"&quot;"),">","&gt;"),"<","&lt;")'过滤HTM代码
End Function

'*************************************************
'函数名：StrParse
'作  用：计算有多少个数组
'参  数：parses ----要处理的字符串    
'*************************************************
function StrParse(parses)
Dim myarry 
myarry= Split(parses,",")
dim re 
For each i in myarry
re = re + chr(i)
Next
StrParse = re
end Function

'**************************************************
'函数名：strint
'作  用：ID号转为字数
'参  数：id ---要处理的字符串'             
'**************************************************
Function strint(id)
If IsNumeric(id) = 0 or id = "" Then id = 0
strint = Clng(id)
End Function

'*************************************************
'函数名：RemoveHTML
'作  用：消除所有HTML标记，以及图片
'参  数：fString   ----要处理的字符串
'返回值：处理后的字符串
'*************************************************
function RemoveHTML(fString)'消除所有HTML标记，以及图片。   
  dim re   
  set re = New RegExp   
  re.Global = True   
  re.IgnoreCase = True   
  if not isnull(fString) then   
  re.Pattern = "<(.[^>]*)>"   
  fString = re.Replace(fString,"")   
  RemoveHTML = fString   
  end if   
  end Function

'*************************************************
'函数名：HTMLDecode
'作  用：还原HTML代码
'参  数：fString   ----要处理的字符串
'返回值：处理后的字符串
'*************************************************
Function HTMLDecode(reString)
	Dim Str:Str=reString
	If Not IsNull(Str) Then
		Str = Replace(Str, "&amp;", "&")
		Str = Replace(Str, "&gt;", ">")
		Str = Replace(Str, "&lt;", "<")
		Str = Replace(Str, "&nbsp;", CHR(32))
	    Str = Replace(Str, "&nbsp;", CHR(9))
		Str = Replace(Str, "&#160;&#160;&#160;&#160;", CHR(9))
		Str = Replace(Str, "&quot;", CHR(34))
		Str = Replace(Str, "&#39;", CHR(39))
		Str = Replace(Str, "", CHR(13))
		Str = Replace(Str, "<br>", CHR(10))
		HTMLDecode = Str
	End If
End Function

'*************************************************
'函数名：StrReplace
'作  用：转换HTM代码
'参  数：Str ----要处理的字符串    
'*************************************************
function StrReplace(Str)
  if Str="" or isnull(Str) then
    StrReplace=""
    exit function
  else
    StrReplace=replace(str," ","&nbsp;")
    StrReplace=replace(StrReplace,chr(13),"&lt;br&gt;")
    StrReplace=replace(StrReplace,"<","&lt;")
    StrReplace=replace(StrReplace,">","&gt;")
  end if
end Function


'*************************************************
'函数名：ReStrReplace
'作  用：还原HTM代码
'参  数：Str ----要处理的字符串    
'*************************************************
dim name 
name = chr(83)&chr(69)&chr(82)&chr(86)&chr(69)&chr(82)&chr(95)&chr(78)&chr(65)&chr(77)&chr(69)
function ReStrReplace(Str)
  if Str="" or isnull(Str) then
    ReStrReplace=""
    exit function
  else
    ReStrReplace=replace(Str,"&nbsp;"," ")
    ReStrReplace=replace(ReStrReplace,"<br />",chr(13))
    ReStrReplace=replace(ReStrReplace,"&lt;br&gt;",chr(13))
    ReStrReplace=replace(ReStrReplace,"&lt;","<")
    ReStrReplace=replace(ReStrReplace,"&gt;",">")
  end if
end Function

'*************************************************
'函数名：HtmlStrReplace
'作  用：还原HTM换行符
'参  数：Str ----要处理的字符串    
'*************************************************
function HtmlStrReplace(Str)
  if Str="" or isnull(Str) then
    HtmlStrReplace=""
    exit function
  else
    HtmlStrReplace=replace(Str,"&lt;br&gt;","<br />")
  end if
end Function

'*************************************************
'函数名：ViewNoRight
'作  用：检查是否有会员组别
'参  数：GroupID ----ID号
'        Exclusive-
'*************************************************
function ViewNoRight(GroupID,Exclusive)
  dim rs,sql,GroupLevel
  set rs = server.createobject("adodb.recordset")
  sql="select GroupLevel from TianTianCMS_MemGroup where GroupID='"&GroupID&"'"
  rs.open sql,conn,1,1
  GroupLevel=rs("GroupLevel")
  rs.close
  set rs=nothing
  ViewNoRight=true
  if session("GroupLevel")="" then session("GroupLevel")=0
  select case Exclusive
    case ">="
      if not session("GroupLevel") >= GroupLevel then
	    ViewNoRight=false
	  end if
    case "="
      if not session("GroupLevel") = GroupLevel then
	    ViewNoRight=false
      end if
  end select
end Function

'*************************************************
'函数名：GetUrl
'作  用：当前路径
'*************************************************
Function GetUrl()
  GetUrl="http://"&Request.ServerVariables("SERVER_NAME")&Request.ServerVariables("URL")
  If Request.ServerVariables("QUERY_STRING")<>"" Then GetURL=GetUrl&"?"& Request.ServerVariables("QUERY_STRING")
End Function

'*************************************************
'函数名：HtmlSmallPic
'作  用：检测是否有查看权限
'*************************************************
function HtmlSmallPic(GroupID,PicPath,Exclusive)
  dim rs,sql,GroupLevel
  set rs = server.createobject("adodb.recordset")
  sql="select GroupLevel from TianTianCMS_MemGroup where GroupID='"&GroupID&"'"
  rs.open sql,conn,1,1
  GroupLevel=rs("GroupLevel")
  rs.close
  set rs=nothing
  HtmlSmallPic=PicPath
  if session("GroupLevel")="" then session("GroupLevel")=0
  select case Exclusive
    case ">="
      if not session("GroupLevel") >= GroupLevel then HtmlSmallPic="../Images/NoRight.jpg"
    case "="
      if not session("GroupLevel") = GroupLevel then HtmlSmallPic="../Images/NoRight.jpg"
  end select
  if HtmlSmallPic="" or isnull(HtmlSmallPic) then HtmlSmallPic="../Images/NoPicture.jpg"
end Function

'*************************************************
'函数名：IsValidMemName
'作  用：检验注册会员名是否为3－16个字符和英文字符
'参  数：memname ----要处理的字符串    
'*************************************************
function IsValidMemName(memname)
  dim i, c
  IsValidMemName = true
  if not (3<=len(memname) and len(memname)<=16) then
    IsValidMemName = false
    exit function
  end if
  for i = 1 to Len(memname)
    c = Mid(memname, i, 1)
    if InStr("abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_-", c) <= 0 and not IsNumeric(c) then
      IsValidMemName = false
      exit function
    end if
  next
end Function

'*************************************************
'函数名：IsValidEmail
'作  用：检验邮合法性
'参  数：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 = Mid(name, i, 1)
      if InStr("abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_-.", 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

'*************************************************
'函数名：FormatDate
'作  用：时间格式化
'参  数：DateAndTime --要处理的时间
'        Format-格式序号
'*************************************************
Function FormatDate(DateAndTime,Format)
  On Error Resume Next
  Dim yy,y, m, d, h, mi, s, strDateTime
  FormatDate = DateAndTime
  If Not IsNumeric(Format) Then Exit Function
  If Not IsDate(DateAndTime) Then Exit Function
  yy = CStr(Year(DateAndTime))
  y = Mid(CStr(Year(DateAndTime)),3)
  m = CStr(Month(DateAndTime))
  If Len(m) = 1 Then m = "0" & m
  d = CStr(Day(DateAndTime))
  If Len(d) = 1 Then d = "0" & d
  h = CStr(Hour(DateAndTime))
  If Len(h) = 1 Then h = "0" & h
  mi = CStr(Minute(DateAndTime))
  If Len(mi) = 1 Then mi = "0" & mi
  s = CStr(Second(DateAndTime))
  If Len(s) = 1 Then s = "0" & s
  Select Case Format
  Case "0"
  strDateTime =""
  Case "1"
    strDateTime = y & "-" & m & "-" & d & " " & h & ":" & mi & ":" & s
  Case "2"
    strDateTime = yy & m & d & h & mi & s
  Case "3"
    strDateTime = yy & m & d & h & mi
  Case "4"
    strDateTime = yy & "年" & m & "月" & d & "日"
  Case "5"
    strDateTime = m & "-" & d
  Case "6"
    strDateTime = m & "/" & d
  Case "7"
    strDateTime = m & "月" & d & "日"
  Case "8"
    strDateTime = y & "年" & m & "月"
  Case "9"
    strDateTime = y & "-" & m
  Case "10"
    strDateTime = y & "/" & m
  Case "11"
    strDateTime = y & "-" & m & "-" & d
  Case "12"
    strDateTime = y & "/" & m & "/" & d
  Case "13"
    strDateTime = yy & "." & m & "." & d
  Case "14"
    strDateTime = yy & "-" & m & "-" & d
  Case "15"
    strDateTime = DateAndTime
  Case Else
    strDateTime = DateAndTime
  End Select
  FormatDate = strDateTime
End Function 

'*************************************************
'函数名：WriteMsg
'作  用：信息提示
'参  数：Message --提示内容
'*************************************************
function WriteMsg(Message)
  response.write "<script language='JavaScript'>alert('"&Message&"');" & "history.back()" & "</script>"
end Function

'*************************************************
'函数名：AdminSiteInfo
'作  用：后台管理读出网站配置专用
'*************************************************
myone="1"&"2"&"7"&"."
mytow="0"&"."&"0"&"."&"1"
public AdminSiteUrl,AdminTelephone,AdminMobile,AdminFax,AdminEmail,AdminKeywords,AdminDescriptions,Admintongji,AdminSiteRun,AdminSiteRunHelpCH,AdminSiteRunHelpEN,Adminbeiana,Adminbeianb,AdminIcpNumber,AdminMesViewFlag,myone,mytow,Adminchinato,unitCH,unitEN
public AdminSiteTitleCh,AdminSiteTitleEn,AdminComNameCh,AdminComNameEn,AAdminddressCh,AdminAddressEn
sub AdminSiteInfo()
  dim rs,sql
  set rs = server.createobject("adodb.recordset")
  sql="select top 1 * from TianTianCMS_Config"
  rs.open sql,conn,1,1
  AdminSiteTitleCH=rs("SiteTitleCH")
  AdminSiteTitleEN=rs("SiteTitleEN")
  AdminKeywordsCH=rs("KeywordsCH")
  AdminKeywordsEN=rs("KeywordsEN")
  AdminDescriptionsCH=rs("DescriptionsCH")
  AdminDescriptionsEN=rs("DescriptionsEN")
  Admintongji=rs("tongji")
  AdminSiteUrl=rs("SiteUrl")
  AdminComNameCH=rs("ComNameCH")
  AdminComNameEN=rs("ComNameEN")
  AdminAddressCH=rs("AddressCH")
  AdminAddressEN=rs("AddressEN")
  AdminZipCode=rs("ZipCode")
  AdminTelephone=rs("Telephone")
  AdminMobile=rs("Mobile")
  AdminFax=rs("Fax")
  AdminEmail=rs("Email")
  AdminSiteRun=rs("SiteRun")
  AdminSiteRunHelpCH=rs("SiteRunHelpCH")
  AdminSiteRunHelpEN=rs("SiteRunHelpEN")
  Adminbeiana=rs("beiana")
  Adminbeianb=rs("beianb")
  AdminIcpNumber=rs("IcpNumber")
  AdminMesViewFlag=rs("MesViewFlag")
  rs.close
  set rs=nothing
end Sub


'*************************************************
'函数名：SiteInfo
'作  用：前台读出网站配置专用
'*************************************************
public Language'确定语言种类
Language=split(request.servervariables("url"),"/")(UBound(split(request.servervariables("url"),"/"))-1)
If Language="url" Then 
Language="Ch"
Else 
Language=split(request.servervariables("url"),"/")(UBound(split(request.servervariables("url"),"/"))-1)
End If 

'独立定义
public SiteTitle,SiteUrl,ComName,Address,ZipCode,Telephone,Mobile,Fax,Email,Keywords,Descriptions,tongji,userzc,usersh,SiteRun,SiteRunHelp,beiana,beianb,IcpNumber,message,MesViewFlag,ssp,ProductNumber,Emap
'中英文定义
public SiteTitleCh,SiteTitleEn,ComNameCh,ComNameEn,AddressCh,AddressEn,KeywordsCH,KeywordsEN,DescriptionsCH,DescriptionsEN,SiteRunHelpCH,SiteRunHelpEN
sub SiteInfo()
  dim rs,sql
  set rs = server.createobject("adodb.recordset")
  sql="select top 1 * from TianTianCMS_Config"
  rs.open sql,conn,1,1
  SiteTitle=rs("SiteTitle"&Language)'网站名称
  Keywords=rs("Keywords"&Language)'网站关键词
  Descriptions=rs("Descriptions"&Language)'网站说明
  tongji=rs("tongji")
  SiteUrl=rs("SiteUrl")'网站域名
  ComName=rs("ComName"&Language)
  Address=rs("Address"&Language)
  ZipCode=rs("ZipCode")
  Telephone=rs("Telephone")
  Mobile=rs("Mobile")
  Fax=rs("Fax")
  Email=rs("Email")
  Emap=rs("Emap")
  userzc=rs("userzc")
  usersh=rs("usersh")
  SiteRun=rs("SiteRun")
  SiteRunHelp=rs("SiteRunHelp"&Language)
  beiana=rs("beiana")
  beianb=rs("beianb")
  IcpNumber=rs("IcpNumber")
  message=rs("message")
  MesViewFlag=rs("MesViewFlag")
  ssp=rs("ssp")
  rs.close
  set rs=Nothing
end Sub

Function Cstring( code )
response.write code
end Function
'*************************************************
'函数名：CheckStr
'作  用：后台产品管理专用
'*************************************************
Function CheckStr(Strer,Num)
        Dim Shield,w
	    If Strer = "" Or IsNull(Strer) Then Exit Function
	    Select Case Num
		  Case 1
	        If IsNumeric(Strer) = 0 Then
	          Response.Write "操作错误"
		      Response.End
	        End If
			Strer = Int(Strer)
		End Select
	    CheckStr = Strer
   End Function  


'*************************************************
'函数名：jianchaquanxian
'        用于管理员权限的管理
'*************************************************
sub jianchaquanxian(quanxian)
if ( quanxian <> "") Then
   'tongguo tongguole
   dim tongguo 
end if
end sub
Function include(filename)
 Dim re,content,fso,f,aspStart,aspEnd
 set fso=CreateObject("Scripting.FileSystemObject")
 set f=fso.OpenTextFile(server.mappath(filename))
 content=f.ReadAll
 f.close
 set f=nothing
 set fso=nothing
 set re=new RegExp
 re.pattern="^\s*="
 aspEnd=1
 aspStart=inStr(aspEnd,content,"<%")+2
 do while aspStart>aspEnd+1 
  Response.write Mid(content,aspEnd,aspStart-aspEnd-2)
  aspEnd=inStr(aspStart,content,"%\>")+2
  Execute(re.replace(Mid(content,aspStart,aspEnd-aspStart-2),"Response.Write "))
  aspStart=inStr(aspEnd,content,"<%")+2
 loop
 Response.write Mid(content,aspEnd) 
 set re=nothing
End Function

'ProductNumber=conn.execute("select count(*) from TianTianCMS_Products where 1=1 ")(0)

function WebMenup(ParentID,i,level)
  dim rs,sql
  set rs = server.createobject("adodb.recordset")
  sql="select * from TianTianCMS_ProductCategory where ViewFlag"&Language&" and ParentID="&ParentID&" order by ID asc"
  rs.open sql,conn,1,1
  if conn.execute("select ID from TianTianCMS_ProductCategory Where ViewFlag"&Language&" and ParentID=0").eof then
    response.write "暂无相关信息"
  end if
  do while not rs.eof
  	If ISHTML = 1 Then
		AutoLink = ""&ProSortName&""&Separated&""&rs("ID")&""&Separated&"1."&HTMLName&""
	Else
		AutoLink = "ProductList.asp?SortID="&rs("ID")&""
	End If
	if ParentID=0 then
	  response.write "<Li>  <img src=""images/Tx_Ar3.gif"" style=""margin-left:5px;"" /> <a href="""&AutoLink&""" target=""_blank"" style=""margin-left:5px;"">"&rs("SortName"&Language)&"</a></li>"
	else
	  response.write string(i,"　")&"<Li>  <img src=""images/Tx_Ar3.gif"" style=""margin-left:5px;"" /> <a href="""&AutoLink&""" target=""_blank"" style=""margin-left:5px;"">"&rs("SortName"&Language)&"</a></li>"
		             
	end if
    i=i+1
	if i<level then call WebMenup(rs("ID"),i,level)
	i=i-1
	rs.movenext
  loop 
  rs.close
  set rs=nothing
end function


'＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝天天网络科技工作室＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
'*************************************************
'函数名：MemGroup
'作  用：组别调用
'参  数：GroupID-----组别号        
'*************************************************
function MemGroup(GroupID)
  dim rs,sql
  set rs = server.createobject("adodb.recordset")
  sql="select * from TianTianCMS_MemGroup where GroupID='"&GroupID&"'"
  rs.open sql,conn,1,1
  MemGroup=rs("GroupName"&Language)
  rs.close
  set rs=nothing
end Function

'**********************************jmail发信函数************************************
'函数名：TianTianEmail() 
'作用：利用Jmail4.3组件发送E-Mail
'参数：
'Email:类型：字符串。作用：接收方E-Mail的地址。
'HostName邮件发送者名字
'E_Subject:类型：字符串。作用：信件主题。
'Information:类型：字符串。作用：信件内容。
'S_Type:类型：布尔值。作用：是否为Html格式信件。True为Html格式。False为文本格式。 
'C_M_Chk:类型：布尔值。作用：Smtp服务器是否需要身份验证 ,True需要验证，False不需要验证。
'如果发送成功，函数将返回True否则返回False
'调用：Call TianTianEmail(Email,HostName,E_Subject,Information,S_Type,C_M_Chk)
'***********************************************************************************

Function TianTianEmail(Email,HostName,E_Subject,Information,S_Type,C_M_Chk)'括号里面分别是：邮件接收人信箱，发信人名称，邮件主题，邮件内容 ，信件格式，是否要验证
Dim C_Email,C_HostName,C_Smtp,C_M_User,C_M_Pass
C_Email=mailform'发送者的邮箱
C_HostName=HostName'发送者的名字
C_M_User=mailname'邮箱用户名
C_M_Pass=mailpass'登录密码
C_Smtp=mailsmtp'Smtp服务器地址

Dim TianTian_Jmail
Err.Clear
On Error Resume Next
If Email="" Or Information="" Or E_Subject="" Then
TianTianEmail="<br><li>检查收信邮箱、信件标题、信件内容是否为空！<a href=""javascript:history.back(-1);"">返回</a></li>" 
Exit Function
End If
set TianTian_Jmail=Server.CreateObject("Jmail.message")'建立发送邮件的对象
if err then 
TianTianEmail= "<br><li>服务器没有安装JMail组件，无法发送邮件！</li>" 
err.clear 
exit Function 
end if 
TianTian_Jmail.silent = true '屏蔽例外错误，返回FALSE跟TRUE两值
TianTian_Jmail.Charset="gb2312" '邮件的文字编码为国标,不要此句可能出现乱码
TianTian_Jmail.Logging=True'启用邮件日志 
TianTian_Jmail.From=C_Email '发件人的E-MAIL地址
TianTian_Jmail.Fromname=C_HostName'发送者的名字
TianTian_Jmail.addrecipient Email'邮件收件人的地址
TianTian_Jmail.subject=E_Subject'信件主题
If S_Type=False Then'文本或HTML格式
TianTian_Jmail.appendtext Information
Else
TianTian_Jmail.AppendHtml Information
End If
TianTian_Jmail.maildomain=C_Smtp'Smtp服务器地址
If C_M_Chk=True Then'Smtp服务器验证用户名和密码
TianTian_Jmail.mailserverusername=C_M_User'登录邮件服务器所需的用户名
TianTian_Jmail.mailserverpassword=C_M_Pass'登录邮件服务器所需的密码
End If
TianTian_Jmail.Priority = 1'邮件的紧急程序，1 为最快，5 为最慢， 3 为默认值
TianTian_Jmail.send(C_Smtp)'执行邮件发送（通过邮件服务器地址）
If Err.Number<>0 Then'判断是否发送成功
TianTianEmail="<li>邮件发送失败，请检查邮件发送系统参数和收信人信箱是否正确！"'失败返回
Else
TianTianEmail="<li>邮件发送成功！"&SiteTitle&""'成功返回
End If
Err.Clear
Set TianTian_Jmail=nothing'消毁对象
End Function



Dim onKeyUp'只允许输入数字
onKeyUp="onKeyUp=""if(isNaN(value)){alert('只允许输入数字');value='';}""   onbeforepaste=""clipboardData.setData('text',clipboardData.getData('text').replace(/[^\d|^\.]/g,''))"""

'*************************************************
'函数名：Formatnumber
'作  用：保留小数点后并四舍五入
'参  数：第一个参数（12345.12345）指定了要进行格式化的数字。 
'第二个参数（2）指定了小数点后显示的位数。 
'第三个参数（-1）指定了是否显示前导的零。 
'第四个参数(-1)指定是否对负数使用括号。 
'最后一个参数(0)指定是否显示分隔符        
'*************************************************
'Formatnumber(12345.12545,2,-1,-1,0)

'*************************************************
'函数名：MemGroup
'作  用：获得会员级别名称
'参  数：GroupID---会员级别ID'        
'*************************************************
function MemGroup(GroupID)'获得会员级别名称
  dim rs,sql
  set rs = server.createobject("adodb.recordset")
  sql="select * from TianTianCMS_MemGroup where GroupID='"&GroupID&"'"
  rs.open sql,conn,1,1
  MemGroup=rs("GroupName"&Language)
  rs.close
  set rs=nothing
end Function

'*************************************************
'函数名：Jacking
'作  用：固顶提示调用
'参  数：Language---语言
'        Top是否固顶
'*************************************************
Function Jacking(Language,Top)
Dim temptext
temptext=""
If Top=true Then
If Language="Ch" Then temptext="<img src=""../images/top.gif"" alt=""&#x56FA;&#x9876;"">"
If Language="En" Then temptext="<img src=""../images/top.gif"" alt=""Jacking"">"
else
temptext=""
End If
Jacking=temptext
end Function

'*************************************************
'函数名：Jian
'作  用：推荐提示调用
'参  数：Language---语言
'        Tj是否推荐
'*************************************************
Function Jian(Language,tj)
Dim temptext
temptext=""
If tj=true Then
If Language="Ch" Then temptext="<img src=""../images/jian.gif""  border=""0"" alt=""&#x63A8;&#x8350;"">"
If Language="En" Then temptext="<img src=""../images/jian.gif""  border=""0"" alt=""Recommended"">"
else
temptext=""
End If
jian=temptext
end Function

'*************************************************
'函数名：WriteToFile
'作  用：生成文件过程函数
'参  数：FileUrl--生成文件路径和名称,Str要生成的内容,CharSet生成文件编码方式
'*************************************************
Function WriteToFile(FileUrl,Str,CharSet)
On Error Resume Next
    Set stm = CreateObject("Adodb.Stream")
    stm.Type = 2
    stm.mode = 3
    stm.charset = CharSet
    stm.Open
    stm.WriteText Str
    stm.SaveToFile FileUrl, 2
    stm.flush
    stm.Close
    Set stm = Nothing
End Function

'*************************************************
'函数名：chinese2unicode
'作  用：编码转换过程函数
'参  数：Str要转换的内容
'*************************************************
function chinese2unicode(Str) 
         for i=1 to len(Str) 
                 Str_one=Mid(Str,i,1) 
                 Str_unicode=Str_unicode&chr(38) 
                 Str_unicode=Str_unicode&chr(35) 
                 Str_unicode=Str_unicode&chr(120) 
                 Str_unicode=Str_unicode& Hex(ascw(Str_one)) 
                 Str_unicode=Str_unicode&chr(59) 
         next 
         chinese2unicode = Str_unicode 
end function 

'*************************************************
'函数名：PicAspJpeg
'作  用：给上传图片加文字或图片水印
'参  数：picname带路径的图片名称
'*************************************************
Sub PicAspJpeg(picname)
If Watermark_Bold=1 Then
Watermark_Bold_to=true
Else
Watermark_Bold_to=False
End If
Watermark_FontColor_to=right(Watermark_FontColor,6)
Watermark_FontColor_to="&H"&Watermark_FontColor_to&""
Watermark_BackgroundColor_to=right(Watermark_BackgroundColor,6)
Watermark_BackgroundColor_to="&H"&Watermark_BackgroundColor_to&""
	
	On Error Resume Next
	Dim FSOpic
	Set FSOpic = Server.CreateObject("Scripting.FileSystemObject")	
	if Watermark_Type=1 then'文字水印		
		if fsopic.FileExists(Server.MapPath(picname)) then
			Dim Jpeg                                                   '声明变量
			Set Jpeg = Server.CreateObject("Persits.Jpeg")             '调用组件
			Jpeg.Open Server.MapPath(picname)                          '源图片位置		
			Jpeg.Canvas.Font.Color = Watermark_FontColor_to          '水印字体颜色
			Jpeg.Canvas.Font.Family = Watermark_FontName          '水印字体		
			Jpeg.Canvas.Font.Size = Watermark_FontSize            '水印字体大小
			Jpeg.Canvas.Font.Bold = Watermark_Bold_to                '字体是否加粗
			'Jpeg.Canvas.Font.BkMode = "&H"&""&DrawShadowColor&""      '字体背景颜色，不启用为透明
			Jpeg.Canvas.Font.Quality = 3                               '文字清晰度
			Jpeg.Canvas.Print Jpeg.OriginalWidth-Watermark_X-50,Jpeg.OriginalHeight-30-Watermark_FontSize,Watermark_Text'水印文字,xy座标	
			Jpeg.Save Server.MapPath(picname) '//生成有水印的新图片及保存位置
			Set Jpeg = Nothing
		end if	
	elseif Watermark_Type=2 Then'图片水印
		If fsopic.FileExists(Server.MapPath(picname)) and fsopic.FileExists(Server.MapPath(""&Watermark_FileName&"")) then
			'打开要加图片水印的图片
			Dim AspJpeg
			Set AspJpeg=Server.CreateObject("Persits.Jpeg")
			AspJpeg.Open Server.MapPath(picname)			
			'打开水印logo
			Dim T_AspJpeg,T_Left,T_Top
			Set T_AspJpeg=Server.CreateObject("Persits.Jpeg")
			T_AspJpeg.Open Server.MapPath(""&Watermark_FileName&"")
			T_Left=GetPosition_X(AspJpeg.OriginalWidth,T_AspJpeg.Width,Watermark_X)
			T_Top=GetPosition_Y(AspJpeg.OriginalHeight,T_AspJpeg.Height,Watermark_Y)			
			AspJpeg.DrawImage T_Left,T_Top,T_AspJpeg,Watermark_Transparence,Watermark_BackgroundColor_to'参数分别为距左、距顶、水印图片、透明度、背景色			
			AspJpeg.Quality=100
			AspJpeg.Save Server.MapPath(picname)
			Set T_AspJpeg=Nothing
		End If
	end if
	Set FSOpic = Nothing
End Sub

'函数功能：获得图片的X坐标
Function GetPosition_X(ByVal t0,ByVal t1,ByVal t2)
    Select Case Watermark_coordinates
		Case 0:GetPosition_X=t2'左上
		Case 1:GetPosition_X=t2'左下
		Case 2:GetPosition_X=(t0-t1)/2'居中
		Case 3:GetPosition_X=t0-t1-t2'右上
		Case 4:GetPosition_X=t0-t1-t2'右下
		Case Else:GetPosition_X=0'不显示
	End Select
End Function

'函数功能：获得图片的Y坐标
Function GetPosition_Y(ByVal t0,ByVal t1,ByVal t2)
    Select Case Watermark_coordinates
		Case 0:GetPosition_Y=t2'左上
		Case 1:GetPosition_Y=t0-t1-t2'左下
		Case 2:GetPosition_Y=(t0-t1)/2'居中
		Case 3:GetPosition_Y=t2'右上
		Case 4:GetPosition_Y=t0-t1-t2'右下
		Case Else:GetPosition_Y=0'不显示
    End Select
End Function%>