www.gusucode.com > 乘风网站推广系统 3.99 (acc)码程序 > CF_MyFunction.asp

    <%
'乘风网站推广系统 Access版
'作者QQ：178575
'作者EMail：yliangcf@163.com
'作者网站：http://www.qqcf.com
'详细简介：http://www.qqcf.com/?action=list&list=cfwztg
'上面有程序在线演示，安装演示，使用疑难解答，最新版本下载等内容
'因为这些内容可能时常更新，就没有放在程序里，请自己上网站查看
%>
<%'以下为公用函数
Function GoBack(ByVal Str,ByVal AlertStr) '为空时后退
 If Str="" Then 
  Response.Write "<script>" 
  Response.Write "alert('"&AlertStr&"');" 
  Response.Write "history.go(-1)" 
  Response.Write "</script>" 
  Call ConnClose()
  Response.End 
 Else
  GoBack=Str
 End If
End Function

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

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

Function AlertClose(ByVal AlertStr)
 Response.Write("<script>")
 Response.Write("alert('" & AlertStr & "');")
 Response.Write("window.close();")
 Response.Write("</script>")
 Response.End()
End Function

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

    Function CheckInput_Letter(ByVal InputStr) '检查用户名输入的合法性
        CheckInput_Letter = -1

        For I = 1 To Len(InputStr)
            C = LCase(Mid(InputStr, I, 1)) '------------分割成每个字母或数字------------------
            If InStr("abcdefghijklmnopqrstuvwxyz_", C) <= 0 And Not IsNumeric(C) Then
                CheckInput_Letter = 0
                Exit For
            End If
        Next
    End Function

    Function CheckInput_Letter_2(ByVal InputStr) '检查字符输入的合法性
        CheckInput_Letter_2 = -1

        For I = 1 To Len(InputStr)
            C = LCase(Mid(InputStr, I, 1)) '------------分割成每个字母或数字------------------
            If InStr("abcdefghijklmnopqrstuvwxyz`-=\[];',./~!@#$%^&*()_+|{}:""<>?", C) <= 0 And Not IsNumeric(C) Then
                CheckInput_Letter_2 = 0
                Exit For
            End If
        Next
    End Function

Function CheckInput_Blank(ByVal 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
   Call ConnClose()
   Response.End
  End If
 Next
  CheckInput_Blank=InputStr
End Function

Function ChkStr(ByVal ParaValue,ByVal ParaType)'参数类型-数字型(1是字符，2是数字，3是日期
 If ParaType = 1 then
  ChkStr = Replace(ParaValue,"'","''")
 ElseIf ParaType = 2 then
  If ParaValue<>"" And (IsNumeric(ParaValue) = False) then
   Response.Write "传递的参数类型有错误！" 
   Response.End
  Else
   ChkStr = ParaValue
  End If
 ElseIf ParaType = 3 then
  If ParaValue<>"" And (IsDate(ParaValue) = False) then
   Response.Write "传递的参数类型有错误！" 
   Response.End
  Else
   ChkStr = ParaValue
  End If
 End If
End Function

Function MyRate(byval snum,byval bnum)
 If isnull(snum) Then snum=0
 If bnum=0 or isnull(bnum) Then bnum=1

 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 MyRateWidth(byval Ratea,byval Rateb,byval Ratec)
 If Rateb=0 Then Rateb=1
 
 MyRateWidth=CLng(Ratea/Rateb*100)
End Function

Function MyRate_2(ByVal 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(ByVal 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 PxFilter(ByVal px,ByVal 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<>"" And Instr(Url,"/")>0 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 GetTurnTime(byval Num)
 Num=Cstr(Num)
 If Len(Num)=1 Then
  GetTurnTime="0"&Num
 Else
  GetTurnTime=Num
 End if
End Function

Function FSOFileRead(ByVal filename)
Dim objFSO,objCountFile,FiletempData
Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
Set objCountFile = objFSO.OpenTextFile(Server.MapPath(filename),1,True)
FSOFileRead = objCountFile.ReadAll
objCountFile.Close
Set objCountFile=Nothing
Set objFSO = Nothing
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 GetUnicode(Str) 
  dim i 
  dim Str_one 
  dim Str_unicode 
  if(isnull(Str)) then
     exit function
  end if
  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 
  GetUnicode=Str_unicode 
end function 

Function GetAdClassName(ByVal Ad_Class) 
 If Ad_Class=1 Then
  GetAdClassName="直接文字广告"
 ElseIf Ad_Class=2 Then
  GetAdClassName="直接图片广告"
 ElseIf Ad_Class=3 Then
  GetAdClassName="网页文字广告"
 ElseIf Ad_Class=4 Then
  GetAdClassName="网页图片广告"
 ElseIf Ad_Class=5 Then
  GetAdClassName="交换文字广告"
 ElseIf Ad_Class=6 Then
  GetAdClassName="交换图片广告"
 ElseIf Ad_Class=7 Then
  GetAdClassName="网页复合广告"
 ElseIf Ad_Class=8 Then
  GetAdClassName="交换弹出广告"
 ElseIf Ad_Class=9 Then
  GetAdClassName="交换退弹广告"
 End If
End Function

Function GenRanStr(ByVal digits)
 Dim output
 Dim Num
 Dim char_array(35)
 char_array(0) = "0"
 char_array(1) = "1"
 char_array(2) = "2"
 char_array(3) = "3"
 char_array(4) = "4"
 char_array(5) = "5"
 char_array(6) = "6"
 char_array(7) = "7"
 char_array(8) = "8"
 char_array(9) = "9"
 char_array(10) = "a"
 char_array(11) = "b"
 char_array(12) = "c"
 char_array(13) = "d"
 char_array(14) = "e"
 char_array(15) = "f"
 char_array(16) = "g"
 char_array(17) = "h"
 char_array(18) = "i"
 char_array(19) = "j"
 char_array(20) = "k"
 char_array(21) = "l"
 char_array(22) = "m"
 char_array(23) = "n"
 char_array(24) = "o"
 char_array(25) = "p"
 char_array(26) = "q"
 char_array(27) = "r"
 char_array(28) = "s"
 char_array(29) = "t"
 char_array(30) = "u"
 char_array(31) = "v"
 char_array(32) = "w"
 char_array(33) = "x"
 char_array(34) = "y"
 char_array(35) = "z"
 
 output=""
 num=""

 Randomize()
 Do While Len(output) < digits
  Num = char_array(Int(36*Rnd))
  output = output + Num
 Loop

 GenRanStr = output
End Function

Function GenRanStr_2(ByVal digits) 
 dim char_array_2(9)
 char_array_2(0) = "0"
 char_array_2(1) = "1"
 char_array_2(2) = "2"
 char_array_2(3) = "3"
 char_array_2(4) = "4"
 char_array_2(5) = "5"
 char_array_2(6) = "6"
 char_array_2(7) = "7"
 char_array_2(8) = "8"
 char_array_2(9) = "9"

 randomize
 do while len(output_2)<digits
 num_2 = char_array_2(Int(10*Rnd))
 output_2 = output_2 + num_2
 loop
 GenRanStr_2 = output_2
End Function


Function GenRanStr_3(ByVal digits)
 Dim output_3
 Dim Num_3
 Dim char_array_3(25)
 char_array_3(0) = "a"
 char_array_3(1) = "b"
 char_array_3(2) = "c"
 char_array_3(3) = "d"
 char_array_3(4) = "e"
 char_array_3(5) = "f"
 char_array_3(6) = "g"
 char_array_3(7) = "h"
 char_array_3(8) = "i"
 char_array_3(9) = "j"
 char_array_3(10) = "k"
 char_array_3(11) = "l"
 char_array_3(12) = "m"
 char_array_3(13) = "n"
 char_array_3(14) = "o"
 char_array_3(15) = "p"
 char_array_3(16) = "q"
 char_array_3(17) = "r"
 char_array_3(18) = "s"
 char_array_3(19) = "t"
 char_array_3(20) = "u"
 char_array_3(21) = "v"
 char_array_3(22) = "w"
 char_array_3(23) = "x"
 char_array_3(24) = "y"
 char_array_3(25) = "z"

 Randomize()
 Do While Len(output_3) < digits
  Num_3 = char_array_3(Int(26 * Rnd))
  output_3 = output_3 + Num_3
 Loop
 GenRanStr_3 = output_3
End Function


Function GetMySet(ByVal AppName, ByVal SetBClassFlag, ByVal SetFlag)
 J_MySet=0

 If AppName="" Then
   Sql = "Select SetValue From CFWztg_SetBClass Where SetBClassFlag='" & SetBClassFlag & "'"
   Set Rs_MySet = Conn.Execute(Sql)
   MyArray_MySet = Split(Rs_MySet("SetValue"), "|||")
   Rs_MySet.Close
 Else
  If IsEmpty(Application(AppName)) Then
   Sql = "Select SetValue From CFWztg_SetBClass Where SetBClassFlag='" & SetBClassFlag & "'"
   Set Rs_MySet = Conn.Execute(Sql)
   Application(AppName) = Rs_MySet("SetValue")
   Rs_MySet.Close
  End If
  MyArray_MySet = Split(Application(AppName), "|||")
 End If
 
 For I_MySet = 0 To UBound(MyArray_MySet)
  If LCase(Left(MyArray_MySet(I_MySet), Len(SetFlag) + 1)) = LCase(SetFlag) & "=" Then
   GetMySet = Mid(MyArray_MySet(I_MySet), Len(SetFlag) + 2)
   J_MySet=1
  End If
 Next

 If J_MySet = 0 Then
 Response.Write("document.write(" & Chr(34) & SetFlag & "参数在数据库里没有找到相应配置" & Chr(34) & ");")
 Response.End()
 End If
End Function

Function GetSet(ByVal App, ByVal MyStr)
 MyArray_Set = Split(App, "|||")

 For I_Set = 0 To UBound(MyArray_Set)
  If LCase(Left(MyArray_Set(I_Set), Len(MyStr) + 1)) = LCase(MyStr) & "=" Then GetSet = Mid(MyArray_Set(I_Set), Len(MyStr) + 2)
 Next
End Function

Function GetSet_2(ByVal App, ByVal MyStr, ByVal SplitStr)
 MyArray_Set_2 = Split(App, SplitStr)

 For I_Set_2 = 0 To UBound(MyArray_Set_2)
  If LCase(Left(MyArray_Set_2(I_Set_2), Len(MyStr) + 1)) = LCase(MyStr) & "=" Then GetSet_2 = Mid(MyArray_Set_2(I_Set_2), Len(MyStr) + 2)
 Next
End Function

Function DollarConVert(ByVal MyCent)
 MyCent=Cstr(MyCent)
 If Instr(MyCent,".")=1 Then MyCent="0"&MyCent
 If Len(MyCent)=3 Then MyCent=MyCent&"0"
 If MyCent="0" Then MyCent="0.00"
 DollarConVert=MyCent
End Function

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

 Sql="Select * from CFWztg_IpAddress where Ip_1<="&inIPnum&" and Ip_2>="&inIPnum
 set RsIp=conn.Execute(Sql)

 If Not RsIp.Eof Then
  If RsIp("Area")<>"" Then GetIpArea = RsIp("Area")
 Else
  GetIpArea= "-"
 End If
 RsIp.Close
End Function


Function GetSkinColor(byval SkinColor,byval Assort)
 MyArray_SkinColor=Split(SkinColor,"|")
 If Assort<=Ubound(MyArray_SkinColor) Then
  GetSkinColor=MyArray_SkinColor(Assort)
 End If
End Function


Function ConnClose()
 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

 If IsObject(Conn)=True Then
  Conn.Close
  Set Conn=Nothing
 End If
End Function
%>