<%
Const EARTH_RADIUS = 6378.137
Const PI=3.1415926
Class C_Manage

Public mailHost
Public mailUsername
Public mailPassword
Public mailFrom
Public mailFromName
Public errorCode
Public mailMax

Private Sub Class_Initialize
	errorCode		=0000000
	version			="1.0"
	mailHost		="smtp.exmail.qq.com"
	mailUsername	="app@qq.com"
	mailPassword	=""'					""
	mailFrom		="app@qq.com"
	mailFromName	="在线订单系统"	
	mailMax=300
End Sub


'创建RS对象
Sub crs(rs)
	set rs=server.CreateObject("adodb.recordset")
	
End Sub
'销毁RS
Sub drs(rs)
	rs=close
	set rs=nothing
End Sub
Sub cexe(sql)
	'response.Write sql
	set thisconn=server.CreateObject("adodb.connection")
	thisconn.open dstr
	thisconn.execute(sql)
	thisconn.close
	set thisconn=nothing	
End Sub
Sub cexeNew(sql,dst)
	'response.Write sql
	set thisconn=server.CreateObject("adodb.connection")
	thisconn.open dst
	thisconn.execute(sql)
	thisconn.close
	set thisconn=nothing	
End Sub
'============================
'发送邮件
'============================


Function SendMail(Email,Subject,Content)
set jm=Server.CreateObject("JMail.Message")

	if err then
       err.clear
       SendMail= "fail"
       jm.close()
       Set jm=nothing
       exit function
    end if
	jm.silent=true
	jm.logging=true
	jm.contenttype="text/html"
	jm.Charset="GB2312"
	jm.ISOEncodeHeaders = false '是否进行ISO编码，默认为True(加上了这一句)
	jm.ReturnReceipt = True
	jm.MailServerUserName=mailUsername
	jm.MailServerPassWord=mailPassword
	jm.From=mailFrom
	jm.FromName=mailFromName
	jm.AddRecipient Email
	jm.Subject=Subject
	jm.Body=Content
	jm.Priority=1
	JMailstat=jm.Send(mailHost)
	jm.close
	Set jm=nothing
	SendMail=JMailstat
End Function
	
	'定义下拉列表参数
	Public Select_NameStr
	Public Select_ValueStr
	
	'输出分页列表
	'参数说明：pNum-当前页；pAllNum-总页数;pStr-参数
	Function PageList(pNum,pAllNum,pStr,op)
		Dim benNum,endNum
		If  pAllNum<=10 Then
			For i=1 To Cint(pAllNum)
				If i=Cint(pNum) Then
				Response.Write("<span class='current'>"&i&"</span>"&" ")
				else
				
				Response.Write("<a href='"&pStr&i&"/"&op&"'>"&i&"</a>"&" ")
				end if
			Next
		Else
			If pNum-1<=5 Then
				benNum=1
			Else
				benNum=pNum-5
			End If
			
			If pAllNum-pNum<=5 Then
				endNum=pAllNum
			Else
				endNum=pNum+5
			End If
			
			For i=benNum to endNum
				If i=Cint(pNum) Then
					Response.Write("<span class='current'>"&i&"</span>"&" ")
				Else
					Response.Write("<a href='"&pStr&i&"/"&op&"'>"&i&"</a>"&" ")
				End If
			Next
		End If
	End Function
	
	
	'输出分页列表
	'参数说明：pNum-当前页；pAllNum-总页数;pStr-参数
	Function PageListActive(pNum,pAllNum,pStr)
		Dim benNum,endNum
		
		If  pAllNum<=10 Then
			For i=1 To pAllNum	
				thispStr=pStr
				If pNum=i Then
				Response.Write("<a class='active'>"&i&"</a>")
				else
				Response.Write("<a href='"&REPLACE(thispStr,"$page$",i)&"'>"&i&"</a>")
				end if
			Next
		Else
			If pNum-1<=5 Then
				benNum=1
			Else
				benNum=pNum-5
			End If
			
			If pAllNum-pNum<=5 Then
				endNum=pAllNum
			Else
				endNum=pNum+5
			End If
			
			For i=benNum to endNum
				thispStr=pStr
				If pNum=i Then
				Response.Write("<a class='active'>"&i&"</a>")
				else
				Response.Write("<a href='"&REPLACE(thispStr,"$page$",i)&"'>"&i&"</a>")
				end if
			Next
		End If
	End Function
	

	

	
	
	

	



		
	

	
	
	'保存textarea的数据转换
	Function SaveTextArea(tStr)
		If tStr="" Or ISNull(tStr) Then
			SaveTextArea=""
		Else
			SaveTextArea=Replace(tStr," ","&nbsp;")
			SaveTextArea=Replace(tStr,"<","＜")
			SaveTextArea=Replace(tStr,"<","＞")
			SaveTextArea=Replace(tStr,Vbcrlf,"<br>")
		End If
	End Function
	
	'读取textarea的数据转换
	Function ReadTextArea(tStr)
		If tStr="" Or ISNull(tStr) Then
			ReadTextArea=""
		Else
			ReadTextArea=Replace(tStr,"&nbsp;"," ")
			ReadTextArea=Replace(tStr,"<br>",Vbcrlf)
		End If
	End Function
	
	
	'JS弹出提示，
	'jStr---提示的内容，jNum----1：返回,2:终止
	Function JsCheck(jStr,jNum)
		Select Case jNum
		
			Case 1
				Response.Write("<script>alert('"&jStr&"');history.go(-1);</script>")
				Response.End()
			Case 2
				Response.Write("<script>alert('"&jStr&"');</script>")
				Response.End()
			Case else
		End Select 
	End Function
	
	
	'JS弹出提示，并且跳转
	'jStr---提示的内容，uStr----跳转地址
	Function JsGoto(jStr,uStr)			
				Response.Write("<script>alert('"&jStr&"');location.replace('"&uStr&"');</script>")
				Response.End() 
	End Function
	
Function FitLen(str,minl,maxl)
	FitLen=false
	if str="" or isnull(str) then exit function	
	if len(str)>=minl and len(str)<=maxl then FitLen=true
End Function

	




'=======================
'判断指定的字符串是否符合指定的正则表达式,符合-True;不符合-false
'=======================
Function TestReg(parmStr,regStr)
Dim TestLable
TestLable=parmStr
If TestLable="" Or Isnull(TestLable) Or regStr="" then
	TestReg=false
	exit function
End If

 Dim regEx, retVal            ' 建立变量。
  Set regEx = New RegExp         ' 建立正则表达式。
  	'regEx.Pattern = "^\w{8}-\w{4}-\w{4}-\w{4}-\w{12}$"         ' 设置模式。
	regEx.Pattern = regStr
  	regEx.IgnoreCase = False         ' 设置是否区分大小写
 	retVal = regEx.Test(TestLable)         ' 执行搜索测试。
If not retVal then
	TestReg=false
	exit function
Else
	TestReg=true
End If 
End Function

 Function RemoveHtml(ByVal str)
		On Error Resume Next
		if str="" Then exit function
		Dim re:Set re=new RegExp
		re.IgnoreCase=True
		re.Global=True
		re.Pattern="<(.[^>]*)>"
		str=re.Replace(str, "")
		Set re=Nothing
		RemoveHtml=str
	End Function
'去掉链接	
Function RemoveA(ByVal str)
		On Error Resume Next
		if str="" Then exit function
		Dim re:Set re=new RegExp
		re.IgnoreCase=True
		re.Global=True
		re.Pattern="<a\s+(?:(?!</a>).)*?>|</a>"
		str=re.Replace(str, "")
		Set re=Nothing
		RemoveA=str
End Function


'去掉Div	
Function RemoveDiv(ByVal str)
		On Error Resume Next
		if str="" Then exit function
		Dim re:Set re=new RegExp
		re.IgnoreCase=True
		re.Global=True
		re.Pattern="<div\s+(?:(?!</div>).)*?>|</div>"
		str=re.Replace(str, "")
		Set re=Nothing
		RemoveDiv=str
End Function


Public Function CheckTitle(str)
		If Not IsNull(str) Then
			str = Replace(str, ">", "&gt;")
			str = Replace(str, "<", "&lt;")
			str = Replace(str, Chr(34), "&quot;")
			str = Replace(str, Chr(39), "&#39;")
			str = Replace(str, Chr(13), "")
			str = Replace(str, Chr(10), "")
			str = Replace(str, "&nbsp;", " ")
			CheckTitle=Trim(str)
		Else
			CheckTitle=""
		End If
	End Function

Public Function CheckBadstr(str)
		If IsNull(str) Then
			CheckBadstr = vbNullString
			Exit Function
		End If
		str = Replace(str, Chr(0), vbNullString) : str = Replace(str, Chr(34), vbNullString)
		str = Replace(str, Chr(9), vbNullString) : str = Replace(str, Chr(255), vbNullString)
		str = Replace(str, "+", "＋") : str = Replace(str, ")", "）")
		str = Replace(str, "(", "（") : str = Replace(str, "%", "％")
		str = Replace(str, "$", "＄") : str = Replace(str, "'", "''")
		str = Replace(str, ";", "；") : str = Replace(str, "*", "＊")
		str = Replace(str, "<", "＜") : str = Replace(str, ">", "＞")
		str = Replace(str, "@", "＠") : str = Replace(str, "--", "－－")
		CheckBadstr = Trim(str)
	End Function
	
Function GetAdd(id)
	GetAdd=""
	if testreg(id,"^\d{1,5}$") then
		crs addrs
		addrs.open "select a_name from b2conline_area where a_id="&id,dstr,1,1
		if not(addrs.eof and addrs.bof) then GetAdd=addrs("a_name")
		drs addrs		
	end if
End Function	
	

'获取机器GUID值，全局唯一
Function GenerateGuid()  
    Dim TypeLib  
    Set TypeLib = Server.CreateObject("Scriptlet.TypeLib")  
    GenerateGuid = TypeLib.Guid  
	GenerateGuid = Lcase(Mid(GenerateGuid,2,36))
End Function


Function GetTimestamp(TimeZone,Sj)
thisTime=DateAdd("h",TimeZone,Sj)
GetTimestamp=Datediff("s","1970-01-01 00:00:00",thisTime)
End Function

Function TimestampToDate(TimeZone,tnap)
TimestampToDate=DateAdd("s",tnap,"1970-01-01 00:00:00")
TimestampToDate=DateAdd("h",TimeZone,TimestampToDate)
End Function

'==================================================
'函数名：GetHttpPage
'作 用：获取网页源码
'参 数：HttpUrl ------网页地址
'==================================================
Function GetHttpPage(HttpUrl)
If IsNull(HttpUrl)=True Or Len(HttpUrl)<18 Or HttpUrl="$False$" Then
GetHttpPage="$False$"
Exit Function
End If
Dim Http
Set Http=server.createobject("msxml2.serverxmlhttp.3.0")
Http.setTimeouts 100000, 100000, 100000, 100000 
Http.open "GET",HttpUrl,False
Http.Send()
If Http.Readystate<>4 Or (Http.status<>200) then
Set Http=Nothing 
GetHttpPage="$False$"
Exit function
End if
GetHTTPPage=bytesToBSTR(Http.responseBody,"GB2312")
Set Http=Nothing
If Err.number<>0 then
Err.Clear
End If
End Function
'==================================================
'函数名：BytesToBstr
'作 用：将获取的源码转换为中文
'参 数：Body ------要转换的变量
'参 数：Cset ------要转换的类型
'==================================================
Function BytesToBstr(Body,Cset)

Dim Objstream
Set Objstream = Server.CreateObject("adodb.stream")
objstream.Type = 1
objstream.Mode =3
objstream.Open
objstream.Write body
objstream.Position = 0
objstream.Type = 2
objstream.Charset = Cset
BytesToBstr = objstream.ReadText 
objstream.Close
set objstream = nothing
End Function



public function Query()
        dim backgroundIP, directIP
        backgroundIP = Request.ServerVariables("HTTP_X_FORWARDED_FOR") 
        directIP = Request.ServerVariables("REMOTE_ADDR")
        
        if backgroundIP = "" then
            Query = directIP
        else
            Query = backgroundIP
        end if
    end function
	
function aclog(user,l_type,l_action,l_dis)
	set logconn=server.CreateObject("adodb.connection")
	logconn.open dstr
	logconn.execute("insert into b2conline_admin_log(l_user,l_type,l_source,l_ip,l_dis,l_action) values('"&user&"',"&l_type&",'"&Request.ServerVariables("Url") &"','"&Query()&"','"&CheckBadstr(l_dis)&"',"&l_action&")")
	logconn.close
	set logconn=nothing
end function
	
'###########################
'计算距离
'实例：FormatNumber(Distance(23.119734430,113.408446000,23.123359720,113.374031200)/1000,2)
'###########################

Function rad(d)

   rad= d * PI / 180.0

End Function

Function Distance(lon1 ,lat1 , lon2 , lat2 )

Dim a_2d' As Double
Dim e_2d' As Double
Dim h_2d' As Integer
Dim DEG_2_RAD' As Double
Dim RAD_2_DEG' As Double

Dim x_rads' As Double
Dim y_rads' As Double
Dim n_2ds' As Double
Dim x_2d' As Double
Dim y_2d' As Double
Dim z_2d' As Double
Dim x_radm' As Double
Dim y_radm 'As Double
Dim n_2dm 'As Double
Dim x_2d_mark' As Double
Dim y_2d_mark 'As Double
Dim z_2d_mark 'As Double
Dim curdistance 'As Double

a_2d = 6378137
e_2d = 0.00669438
h_2d = 15
DEG_2_RAD = 0.01745329252
RAD_2_DEG = 57.2957795129

x_rads = Abs(lon1) * DEG_2_RAD
y_rads = Abs(lat1) * DEG_2_RAD


n_2ds = a_2d / Sqr(1 - e_2d * Sin(y_rads) * Sin(y_rads))

x_2d = (n_2ds + h_2d) * Cos(y_rads) * Cos(x_rads)
y_2d = (n_2ds + h_2d) * Cos(y_rads) * Sin(x_rads)
z_2d = (n_2ds * (1 - e_2d) + h_2d) * Sin(y_rads)

x_radm = Abs(lon2) * DEG_2_RAD
y_radm = Abs(lat2) * DEG_2_RAD

n_2dm = a_2d / Sqr(1 - e_2d * Sin(y_radm) * Sin(y_radm))

x_2d_mark = (n_2dm + h_2d) * Cos(y_radm) * Cos(x_radm)
y_2d_mark = (n_2dm + h_2d) * Cos(y_radm) * Sin(x_radm)
z_2d_mark = (n_2dm * (1 - e_2d) + h_2d) * Sin(y_radm)

curdistance = (x_2d_mark - x_2d) * (x_2d_mark - x_2d) + (y_2d_mark - y_2d) * (y_2d_mark - y_2d) + (z_2d_mark - z_2d) * (z_2d_mark - z_2d)
curdistance = Sqr(curdistance)

Distance = curdistance
End Function 





End Class
Dim mObj
Set mObj=New C_Manage
'=================获取地理位置函数
Function GetAddress(IP)
        Dim Wry,IPType
        Set Wry=New TQQWry
        IPType=Wry.QQWry(IP)
        GetAddress=Wry.Country&"-"&Wry.LocalStr
Set Wry = Nothing
End Function
'=================
'=================IP地理检索类对象
Class TQQWry
        Dim Country,LocalStr,Buf,OffSet
        Private StartIP,EndIP,CountryFlag
        Public FirstStartIP,LastStartIP,RecordCount,QQWryFile
        Private Stream,EndIPOff
        
        Private Sub Class_Initialize
                Country=""
                LocalStr=""
                StartIP=0
                EndIP=0
                CountryFlag=0 
                FirstStartIP=0 
                LastStartIP=0 
                EndIPOff=0 
                QQWryFile=Server.MapPath("QQWry.dat")
        End Sub
        
        Function IP2Int(IP)
                Dim IPArray,i
                IPArray=Split(IP,".",-1)
                FOr i=0 to 3
                        If Not IsNumeric(IPArray(i)) Then IPArray(i)=0
                        If CInt(IPArray(i))<0 Then IPArray(i)=Abs(CInt(IPArray(i)))
                        If CInt(IPArray(i))>255 Then IPArray(i)=255
                Next
                IP2Int=(CInt(IPArray(0))*256*256*256)+(CInt(IPArray(1))*256*256)+(CInt(IPArray(2))*256)+CInt(IPArray(3))'-1
        End Function
        
        Function Int2IP(IntValue)
                p4=IntValue-Fix(IntValue/256)*256
                IntValue=(IntValue-p4)/256
                p3=IntValue-Fix(IntValue/256)*256
                IntValue=(IntValue-p3)/256
                p2=IntValue-Fix(IntValue/256)*256
                IntValue=(IntValue-p2)/256
                p1=IntValue
                Int2IP=Cstr(p1)&"."&Cstr(p2)&"."&Cstr(p3)&"."&Cstr(p4)
        End Function
        
        Private Function GetStartIP(RecNo)
                OffSet=FirstStartIP+RecNo * 7
                Stream.Position=OffSet
                Buf=Stream.Read(7)
                
                EndIPOff=AscB(MidB(Buf,5,1))+(AscB(MidB(Buf,6,1))*256)+(AscB(MidB(Buf,7,1))*256*256) 
                StartIP=AscB(MidB(Buf,1,1))+(AscB(MidB(Buf,2,1))*256)+(AscB(MidB(Buf,3,1))*256*256)+(AscB(MidB(Buf,4,1))*256*256*256)
                GetStartIP=StartIP
        End Function
        
        Private Function GetEndIP()
                Stream.Position=EndIPOff
                Buf=Stream.Read(5)
                EndIP=AscB(MidB(Buf,1,1))+(AscB(MidB(Buf,2,1))*256)+(AscB(MidB(Buf,3,1))*256*256)+(AscB(MidB(Buf,4,1))*256*256*256) 
                CountryFlag=AscB(MidB(Buf,5,1))
                GetEndIP=EndIP
        End Function
        
        Private Sub GetCountry(IP)
                If (CountryFlag=1 or CountryFlag=2) Then
                        Country=GetFlagStr(EndIPOff+4)
                        If CountryFlag=1 Then
                                LocalStr=GetFlagStr(Stream.Position)
                                If IP>= IP2Int("255.255.255.0") And IP<=IP2Int("255.255.255.255") Then
                                        LocalStr=GetFlagStr(EndIPOff+21)
                                        Country=GetFlagStr(EndIPOff+12)
                                End If
                        Else
                                LocalStr=GetFlagStr(EndIPOff+8)
                        End If
                Else
                        Country=GetFlagStr(EndIPOff+4)
                        LocalStr=GetFlagStr(Stream.Position)
                End If
                Country=Trim(Country)
                LocalStr=Trim(LocalStr)
                If InStr(Country,"CZ88.NET") Then Country=""
                If InStr(LocalStr,"CZ88.NET") Then LocalStr=""
        End Sub
        
        Private Function GetFlagStr(OffSet)
                Dim Flag
                Flag=0
                Do While (True)
                        Stream.Position=OffSet
                        Flag=AscB(Stream.Read(1))
                        If(Flag=1 or Flag=2 ) Then
                                Buf=Stream.Read(3) 
                                If (Flag=2 ) Then
                                        CountryFlag=2
                                        EndIPOff=OffSet-4
                                End If
                                OffSet=AscB(MidB(Buf,1,1))+(AscB(MidB(Buf,2,1))*256)+(AscB(MidB(Buf,3,1))*256*256)
                        Else
                                Exit Do
                        End If
                Loop
                
                If (OffSet<12 ) Then
                        GetFlagStr=""
                Else
                        Stream.Position=OffSet
                        GetFlagStr=GetStr() 
                End If
        End Function
        
        Private Function GetStr() 
                Dim c
                GetStr=""
                Do While (True)
                        c=AscB(Stream.Read(1))
                        If (c=0) Then Exit Do 
                        
                        If c>127 Then
                                If Stream.EOS Then Exit Do
                                GetStr=GetStr&Chr(AscW(ChrB(AscB(Stream.Read(1)))&ChrB(C)))
                        Else
                                GetStr=GetStr&Chr(c)
                        End If
                Loop 
        End Function
        
        Public Function QQWry(DotIP)
                Dim IP,nRet
                Dim RangB,RangE,RecNo                
                IP=IP2Int(DotIP)                
                Set Stream=CreateObject("ADodb.Stream")
                Stream.Mode=3
                Stream.Type=1
                Stream.Open
                Stream.LoadFromFile QQWryFile
                Stream.Position=0
                Buf=Stream.Read(8)                
                FirstStartIP=AscB(MidB(Buf,1,1))+(AscB(MidB(Buf,2,1))*256)+(AscB(MidB(Buf,3,1))*256*256)+(AscB(MidB(Buf,4,1))*256*256*256)
                LastStartIP=AscB(MidB(Buf,5,1))+(AscB(MidB(Buf,6,1))*256)+(AscB(MidB(Buf,7,1))*256*256)+(AscB(MidB(Buf,8,1))*256*256*256)
                RecordCount=Int((LastStartIP-FirstStartIP)/7)
                If (RecordCount<=1) Then
                        Country="Unknow"
                        QQWry=2
                        Exit Function
                End If                
                RangB=0
                RangE=RecordCount                
                Do While (RangB<(RangE-1)) 
                        RecNo=Int((RangB+RangE)/2) 
                        Call GetStartIP (RecNo)
                        If (IP=StartIP) Then
                                RangB=RecNo
                                Exit Do
                        End If
                        If (IP>StartIP) Then
                                RangB=RecNo
                        Else 
                                RangE=RecNo
                        End If
                Loop                
                Call GetStartIP(RangB)
                Call GetEndIP()
                If (StartIP<=IP) And ( EndIP>=IP) Then
                        nRet=0
                Else
                        nRet=3
                End If
                Call GetCountry(IP)
                QQWry=nRet
        End Function
        Private Sub Class_Terminate()
                On ErrOr Resume Next
                Stream.Close
                If Err Then Err.Clear
                Set Stream=Nothing
        End Sub
        
End Class
'=================

%>