qqcf_myfunction.asp

物流管理系统

<%
'==================================
' 乘风多用户计数器v3.8
' 制　作：乘　风
' 开发网站：http://www.qqcf.com
' 程序演示：http://www.qqcf.com/?action=try
' 最新版本下载：http://www.qqcf.com/?action=down
' 声 明:	
' 本软件系免费程序,提供给个人免费使用,除保留版权外无其它任何限制。
' 我们为付费版用户提供升级服务和技术支持。
' 在程序首页保留乘风原创程序版权和链接的免费用户我们也提供一些的升级服务和技术支持。
' 未经作者许可禁止用于任何商业用途。
' 乘风多用户计数器特有的功能：
' 1.计数器数字图片和统计图标两种机制共存，众多设置可调。
' 2.Script脚本和Img非脚本两种方式调用计数器，Img非脚本方式计数器可以在任何能插入图片的地方使用。
' 3.独有的错误自动修复机制，能在计数器发生错误后自动修复。
' 4.完全杜绝并发线程容易对数据库造成的损坏，在流量大的网站上使用表现很稳定。
' 5.缓存机制，在缓存中保存数据，操作常见动作，大量减少对数据库的增加，删除频繁的操作。
' 6.稳定性、安全性、速度上表现都很优秀，功能齐全，代码集成程度高、完全公开，专业制作，完全免费。
' 乘风其它作品：乘风多用户计数器MsSql版、乘风多用户记数器php版、乘风电影程序、
'　　　　　　　 乘风网站推广系统、乘风网址程序，乘风广告管理系统、乘风论坛等。
' 此段版权注释不会影响网页打开速度，请勿删除!
'　　　　　　　　　　　2006年7月19日									
'===================================
%>
<%'以下为公用函数
Function GoBack(Str,AlertStr) '为空时后退
 If Str="" Then
  Response.Write "<script>"
  Response.Write "alert('"&AlertStr&"');"
  Response.Write "history.go(-1)"
  Response.Write "</script>"
  Response.End 
 Else
  GoBack=Str
 End If
End Function

Function AlertBack(AlertStr,BackNum) 
  Response.Write "<script>"
  Response.Write "alert('"&AlertStr&"');"
  Response.Write "history.go(-"&BackNum&")"
  Response.Write "</script>"
  Response.End 
End Function

Function AlertUrl(AlertStr,Url)
 Response.Write "<script>"
 Response.Write "alert('"&AlertStr&"');"
 Response.Write "location.href='"&Url&"';"
 Response.Write "</script>"
 Response.end
End Function

Function GotoUrl(ByVal Url)
 Response.Write "<script>" 
 Response.Write "location.href='"&Url&"';"
 Response.Write "</script>"
 Response.End 
End Function

Function CheckInput_Letter(InputStr) '检查用户名输入的合法性
 For I = 1 To Len(InputStr)
  C = Lcase(Mid(InputStr, I, 1)) '------------分割成每个字母或数字------------------
  If InStr("abcdefghijklmnopqrstuvwxyz_", C) <= 0 And Not IsNumeric(C) Then
   Response.Write "<script language='javascript'>" & VbCRlf
   Response.Write "alert('请不要在用户名中输入中文,空格或其它非法字符,合法字符为大小写字母,下划线,数字!');" & VbCrlf
   Response.Write "history.go(-1);" & vbCrlf
   Response.Write "</script>" & VbCRLF
   Response.End
  end if
 Next
 CheckInput_Letter=InputStr
End Function

Function CheckInput_Blank(InputStr) '检查密码输入的合法性
 For I = 1 To Len(InputStr)
  c = Lcase(Mid(InputStr, I, 1)) '------------分割成每个字母或数字------------------
  If InStr(" ", c) > 0 Or InStr("　", c) > 0 Then
   Response.Write "<script language='javascript'>" & VbCRlf
   Response.Write "alert('请不要输入空格!');" & VbCrlf
   Response.Write "history.go(-1);" & vbCrlf
   Response.Write "</script>" & VbCRLF
   Response.End
  End If
 Next
  CheckInput_Blank=InputStr
End Function

Function ChkStr(InputStr) '过滤非法字符
 InputStr_2=Lcase(InputStr)
 I=0
 If Instr(InputStr_2,"'")>0 Then
  InputStr_2=Replace(InputStr_2,"'","")
  I=1
 End if
 If Instr(InputStr_2,"select")>0 Then
  InputStr_2=Replace(InputStr_2,"select","")
  I=1
 End if
 If Instr(InputStr_2,"insert")>0 Then
  InputStr_2=Replace(InputStr_2,"insert","")
  I=1
 End if
 If Instr(InputStr_2,"update")>0 Then
  InputStr_2=Replace(InputStr_2,"update","")
  I=1
 End if
 If Instr(InputStr_2,"delete")>0 Then
  InputStr_2=Replace(InputStr_2,"delete","")
  I=1
 End if
 If Instr(InputStr_2,"drop")>0 Then
  InputStr_2=Replace(InputStr_2,"drop","")
  I=1
 End if
 If Instr(InputStr_2,"truncate")>0 Then
  InputStr_2=Replace(InputStr_2,"truncate","")
  I=1
 End if
 If Instr(InputStr_2,"exec")>0 Then
  InputStr_2=Replace(InputStr_2,"exec","")
  I=1
 End if
 If Instr(InputStr_2,"from")>0 Then
  InputStr_2=Replace(InputStr_2,"from","")
  I=1
 End if
 
If I=0 Then
 ChkStr=InputStr
Else
 ChkStr=InputStr_2
End If
End Function

Function GetFieldValues(TalbeName,FieldNmae,Fieldvalues,FieldType,GetFieldName)  '通用,通过一个表的字段，得到表中某个字段的值
 If FieldType=1 Then
  Sql="select "&GetFieldName&" from "& TalbeName &" where "& FieldNmae &"="& Fieldvalues
 ElseIf FieldType=2 Then
  Sql="select "&GetFieldName&" from "& TalbeName &" where "& FieldNmae &"='"& Fieldvalues &"'"
 End If
 Set FieldValues=Server.CreateObject("Adodb.RecordSet")
 FieldValues.Open Sql,Conn,1,1
 If Not FieldValues.Eof Then GetFieldValues=FieldValues(0)
 FieldValues.Close
End function

Function MyRate(snum,bnum)
 MyRate=Cstr((snum/bnum)*100)
 If Instr(MyRate,".")=0 Then
  MyRate=MyRate&".00"
 Else
  If Len(Mid(MyRate,Instr(MyRate,".")+1))=1 Then
   MyRate=MyRate&"0"
  Else
   MyRate=Left(MyRate,Instr(MyRate,".")+2)
  End If
 End If
 If Left(MyRate,Instr(MyRate,".")-1)=0 Then MyRate="0"&MyRate
End Function

Function MyRate_2(num)
 MyRate_2=num
 If Instr(MyRate_2,".")=0 Then
  MyRate_2=MyRate_2&".00"
 Else
  If Len(Mid(MyRate_2,Instr(MyRate_2,".")+1))=1 Then
   MyRate_2=MyRate_2&"0"
  Else
   MyRate_2=Left(MyRate_2,Instr(MyRate_2,".")+2)
  End If
 End If
 If Left(MyRate_2,Instr(MyRate_2,".")-1)=0 Then MyRate_2="0"&MyRate_2
End Function

Function HttpPath(Assort)
 Ser=Request.servervariables("SERVER_NAME")
 Scr=Request.servervariables("SCRIPT_NAME")
 Port=Request.Servervariables("SERVER_PORT")

 Scr_2=StrReverse(Mid(StrReverse(Scr),Instr(StrReverse(Scr),"/")))

 If Assort=1 Then
  HttpPath=Ser 
 ElseIf Assort=2 Then
  If Port="80" Then
   HttpPath="http://"&Ser&Scr_2
  Else
   HttpPath="http://"&Ser&":"&Port&Scr_2
  End If 
 ElseIf Assort=3 Then
  If Port="80" Then
   HttpPath="http://"&Ser&Scr
  Else
   HttpPath="http://"&Ser&":"&Port&Scr
  End If
 End If
End Function

Function GetCurrWeb()
 Url=HttpPath(3)&"?"&Request.QueryString&"&"&Request.Form
 If Mid(Url,Len(Url))="&" Then Url=Left(Url,Len(Url)-1)
 Session("Url")=Url
End Function

Function UrlMd(ByVal Url)
 Url=Replace(Url,"=","denghao")
 Url=Replace(Url,"&","liangjiefu")
 Url = Replace(Url, """", "shuangyinhao")
 Url = Replace(Url, "%22", "shuangyinhao")
 UrlMd=url
End Function

Function UrlDe(ByVal Url)
 Url=Replace(Url,"denghao","=")
 Url=Replace(Url,"liangjiefu","&")
 Url=Replace(Url,"shuangyinhao","%22") 
 UrlDe=Url
End Function


Function PxFilter(px,pxok)
 px=Lcase(px)
 pxok=Lcase(pxok)

 PxArrary=Split(Pxok,",")

 For I= 0 To Ubound(PxArrary)
  If PxArrary(I)=Px Then J=1
 Next

 If J<>1 Then Call AlertBack("禁止此类排序",1)
End Function


Function BreakUrl(ByVal Url,ByVal BreakType)
 Url=Lcase(Url)
 If Url<>"-" Then
  UrlArrary=Split(Url,"/")
  UrlHead=UrlArrary(2)
  UrlTail=UrlArrary(Ubound(UrlArrary))
  If BreakType=1 Then
   BreakUrl=UrlHead
  ElseIf BreakType=2 Then
   If UrlTail<>"" Then
    BreakUrl=UrlTail
   Else
    BreakUrl=UrlHead
   End if
  End if
 Else
  BreakUrl=Url
 End if
End Function

Function GetSearchKeyword(byval Url,byval KeyWordFlag)
 KeyWordFlag=KeyWordFlag&"="

 UrlArrary=Split(Url,KeyWordFlag)

 UrlTail=UrlArrary(1)
 If Instr(UrlTail,"&")=0 Then
  GetSearchKeyword=Mid(UrlTail,1,1000)
 Else
  GetSearchKeyword=Mid(UrlTail,1,Instr(UrlTail,"&")-1)
 End if
End Function


Function GetTurnTime(byval Num)
 Num=Cstr(Num)
 If Len(Num)=1 Then
  GetTurnTime="0"&Num
 Else
  GetTurnTime=Num
 End if
End Function


Function URLDecode(byval enStr)
  dim deStr
  dim c,i,v
  deStr=""
  for i=1 to len(enStr)
  c=Mid(enStr,i,1)
  if c="%" then
  v=eval("&h"+Mid(enStr,i+1,2))
  if v<128 then
  deStr=deStr&chr(v)
  i=i+2
  else
  if isvalidhex(mid(enstr,i,3)) then
  if isvalidhex(mid(enstr,i+3,3)) then
  v=eval("&h"+Mid(enStr,i+1,2)+Mid(enStr,i+4,2))
  deStr=deStr&chr(v)
  i=i+5
  else
  v=eval("&h"+Mid(enStr,i+1,2)+cstr(hex(asc(Mid(enStr,i+3,1)))))
  deStr=deStr&chr(v)
  i=i+3 
  end if 
  else 
  destr=destr&c
  end if
  end if
  else
  if c="+" then
  deStr=deStr&" "
  else
  deStr=deStr&c
  end if
  end if
  next
  URLDecode=deStr
  end function

  function isvalidhex(str)
  isvalidhex=true
  str=ucase(str)
  if len(str)<>3 then isvalidhex=false:exit function
  if left(str,1)<>"%" then isvalidhex=false:exit function
  c=mid(str,2,1)
  if not (((c>="0") and (c<="9")) or ((c>="A") and (c<="Z"))) then isvalidhex=false:exit function
  c=mid(str,3,1)
  if not (((c>="0") and (c<="9")) or ((c>="A") and (c<="Z"))) then isvalidhex=false:exit function
  end function
  

'解码出始
function UTF2GB(byval UTFStr) 
for Dig=1 to len(UTFStr) 
if mid(UTFStr,Dig,1)="%" then 
if len(UTFStr) >= Dig+8 then 
GBStr=GBStr & ConvChinese(mid(UTFStr,Dig,9)) 
Dig=Dig+8 
else 
GBStr=GBStr & mid(UTFStr,Dig,1) 
end if 
else 
GBStr=GBStr & mid(UTFStr,Dig,1) 
end if 
next 
UTF2GB=GBStr 
end function 

function ConvChinese(x) 
A=split(mid(x,2),"%") 
i=0 
j=0 

for i=0 to ubound(A) 
A(i)=c16to2(A(i)) 
next 

for i=0 to ubound(A)-1 
DigS=instr(A(i),"0") 
Unicode="" 
for j=1 to DigS-1 
if j=1 then 
A(i)=right(A(i),len(A(i))-DigS) 
Unicode=Unicode & A(i) 
else 
i=i+1 
A(i)=right(A(i),len(A(i))-2) 
Unicode=Unicode & A(i) 
end if 
next 

if len(c2to16(Unicode))=4 then 
ConvChinese=ConvChinese & chrw(int("&H" & c2to16(Unicode))) 
else 
ConvChinese=ConvChinese & chr(int("&H" & c2to16(Unicode))) 
end if 
next 
end function 

function c2to16(x) 
i=1 
for i=1 to len(x) step 4 
c2to16=c2to16 & hex(c2to10(mid(x,i,4))) 
next 
end function 

function c2to10(x) 
c2to10=0 
if x="0" then exit function 
i=0 
for i= 0 to len(x) -1 
if mid(x,len(x)-i,1)="1" then c2to10=c2to10+2^(i) 
next 
end function 

function c16to2(x) 
i=0 
for i=1 to len(trim(x)) 
tempstr= c10to2(cint(int("&h" & mid(x,i,1)))) 
do while len(tempstr)<4 
tempstr="0" & tempstr 
loop 
c16to2=c16to2 & tempstr 
next 
end function 

function c10to2(x) 
mysign=sgn(x) 
x=abs(x) 
DigS=1 
do 
if x<2^DigS then 
exit do 
else 
DigS=DigS+1 
end if 
loop 
tempnum=x 

i=0 
for i=DigS to 1 step-1 
if tempnum>=2^(i-1) then 
tempnum=tempnum-2^(i-1) 
c10to2=c10to2 & "1" 
else 
c10to2=c10to2 & "0" 
end if 
next 
if mysign=-1 then c10to2="-" & c10to2 
end function 
'解码结束

Function GetIpArea(ByVal Ip)
 connstrIP="DBQ="+server.mappath("QQCF_Data/QQCF_Ip.Mdb")+";DefaultDir=;DRIVER={Microsoft Access Driver (*.mdb)};"
 Set connIP = Server.CreateObject ("ADODB.Connection")
 connIP.open connstrIP

 inIP=Ip
 inIPs=split(inIP,".")
 inIPnum=inips(0)*256*256*256 + inips(1)*256*256 + inips(2)*256 + inips(3)

 Sql="Select * from WWW_QQCF_COM_CfCount_IpAddress where startip<="&inIPnum&" and endip>="&inIPnum
 set RsIp=connIP.Execute(Sql)

 If Not RsIp.Eof Then
  GetIpArea= RsIp("Country")
  If RsIp("City")<>"" Then GetIpArea=GetIpArea& "-"&RsIp("City")
 Else
  GetIpArea= "未知地区"
 End If
 RsIp.Close
End Function

Function GetPicStyle(ByVal User_Name)
 Set RsPicStyle= Server.CreateObject("Adodb.RecordSet")
 Sql="Select * From WWW_QQCF_COM_CfCount_RegUser Where User_Name='"&User_Name&"'"
 RsPicStyle.Open Sql,Conn,1,1
 If RsPicStyle("ShowType")=1 Then
  Counter=RsPicStyle("ShowTotal")
 ElseIf RsPicStyle("ShowType")=2 Then
  Counter=RsPicStyle("RealShowTotal")
 ElseIf RsPicStyle("ShowType")=3 Then
  Counter=RsPicStyle("RealIpTotal")
 End if   
 CountLen=Len(Counter)
 ZeroNum=RsPicStyle("PicNum")-CountLen

 For I=1 To ZeroNum
  LinkUrl="QQCF_CounterPic/"&RsPicStyle("Style")&"/0"
  CounterHtm=CounterHtm&"<img src="&LinkUrl&".gif border='0'>"
 Next
 For I=1 To CountLen
  Pic=Mid(Counter,I,1)
  LinkUrl="QQCF_CounterPic/"&RsPicStyle("Style")&"/"&Pic
  CounterHtm=CounterHtm&"<img src="&LinkUrl&".gif border='0'>"
 Next
 GetPicStyle=CounterHtm
 RsPicStyle.Close
End Function

Function GetAppChange(ByVal User_Name,ByVal IP,ByVal CfCountVisitTotal,ByVal Currweb)
 MyArray=Split(Application(User_Name&"_Ly"),"|")
 For I=0 To Ubound(MyArray)-1
  If Instr(MyArray(I),IP)=0 Then
   AllStr=AllStr&MyArray(I)&"|"
  Else
   MyArray_2=Split(MyArray(I),"\")
   MyStr=Ip&"\"&CfCountVisitTotal&"\"&MyArray_2(2)&"\"&MyArray_2(3)&"\"&Now()&"\"&CurrWeb&"\"&Int(MyArray_2(6))+1&"|"
   AllStr=AllStr&MyStr
  End if
 Next
   
 GetAppChange=AllStr
End Function

Function GetAppChange_2(ByVal User_Name,ByVal IP,ByVal CfCountVisitTotal,ByVal Currweb,ByVal OnlineTime)
 MyArray=Split(Application(User_Name&"_Online"),"|")
 
 If Ubound(Myarray)>1000 Then K=1'只保留1000条记录
 J=0
 For I=K To Ubound(MyArray)-1
  MyArray_2=Split(MyArray(I),"\")
  If Instr(MyArray(I),IP)>0 And J=0 Then   
   MyStr=Ip&"\"&CfCountVisitTotal&"\"&MyArray_2(2)&"\"&MyArray_2(3)&"\"&Now()&"\"&CurrWeb&"\"&Int(MyArray_2(6))+1&"|"
   AllStr=AllStr&MyStr
   J=1
  Else
   If Ubound(MyArray_2)=6 Then
    If DateDiff("n",Cdate(MyArray_2(4)),Now())<=OnlineTime Then AllStr=AllStr&MyArray(I)&"|"
   End If
  End if
 Next
   
 GetAppChange_2=AllStr
End Function

Function connclose()
 If IsObject(Conn)=True Then
  Conn.Close
  Set Conn=Nothing
 End If
 
 If IsObject(Rs)=True Then
  Rs.Close
  Set Rs=Nothing
 End If

 If IsObject(Rs2)=True Then
  Rs2.Close
  Set Rs2=Nothing
 End If

 If IsObject(RsUser)=True Then
  RsUser.Close
  Set RsUser=Nothing
 End If

 If IsObject(RsSet)=True Then
  RsSet.Close
  Set RsSet=Nothing
 End If

 If IsObject(qqcf)=True Then
  qqcf.Close
  Set qqcf=Nothing
 End If

End Function
%>