<%
'*******************************************************************
'取得IP地址
'*******************************************************************
FunctionUserip()
DimGetClientIP
'如果客户端用了代理服务器，则应该用ServerVariables("HTTP_X_FORWARDED_FOR")方法
GetClientIP=Request.ServerVariables("HTTP_X_FORWARDED_FOR")
IfGetClientIP=""orIsNull(GetClientIP)orIsEmpty(GetClientIP)Then
'如果客户端没用代理，应该用Request.ServerVariables("REMOTE_ADDR")方法
GetClientIP=Request.ServerVariables("REMOTE_ADDR")
EndIf
Userip=GetClientIP
EndFunction
'*******************************************************************
'转换IP地址
'*******************************************************************
Functioncip(sip)
tip=CStr(sip)
sip1=Left(tip,CInt(InStr(tip,".")-1))
tip=Mid(tip,CInt(InStr(tip,".")+1))
sip2=Left(tip,CInt(InStr(tip,".")-1))
tip=Mid(tip,CInt(InStr(tip,".")+1))
sip3=Left(tip,CInt(InStr(tip,".")-1))
sip4=Mid(tip,CInt(InStr(tip,".")+1))
cip=CInt(sip1)*256*256*256+CInt(sip2)*256*256+CInt(sip3)*256+CInt(sip4)
EndFunction
'*******************************************************************
'弹出对话框
'*******************************************************************
Subalert(message)
message=Replace(message,"'","'")
Response.Write("<script>alert('"&message&"')</script>")
EndSub
'*******************************************************************
'返回上一页，一般用在判断信息提交是否完全之后
'*******************************************************************
SubGoBack()
Response.Write("<script>history.go(-1)</script>")
EndSub
'*******************************************************************
'重定向另外的连接
'*******************************************************************
SubGo(url)
Response.Write("<script>location.href('"&url&"')</script>")
EndSub
'*******************************************************************
'我比较喜欢将以上三个结合起来使用
'*******************************************************************
FunctionAlert(message,gourl)
message=Replace(message,"'","'")
Ifgourl="-1"Then
Response.Write("<scriptlanguage=javascript>alert('"&message&"');history.go(-1)</script>")
Else
Response.Write("<scriptlanguage=javascript>alert('"&message&"');location='"&gourl&"'</script>")
EndIf
Response.End()
EndFunction
'*******************************************************************
'指定秒数重定向另外的连接
'*******************************************************************
SubGoPage(url,s)
s=s*1000
Response.Write"<SCRIPTLANGUAGE=JavaScript>"
Response.Write"window.setTimeout("&Chr(34)&"window.navigate('"&url&"')"&Chr(34)&","&s&")"
Response.Write"</script>"
EndSub
'*******************************************************************
'判断数字是否整形
'*******************************************************************
FunctionisInteger(para)
OnErrorResumeNext
DimStr
Diml,i
IfIsNull(para)Then
isInteger=False
ExitFunction
EndIf
Str=CStr(para)
IfTrim(Str)=""Then
isInteger=False
ExitFunction
EndIf
l=Len(Str)
Fori=1Tol
IfMid(Str,i,1)>"9"orMid(Str,i,1)<"0"Then
isInteger=False
ExitFunction
EndIf
Next
isInteger=True
IfErr.Number<>0ThenErr.Clear
EndFunction
'*******************************************************************
'获得文件扩展名
'*******************************************************************
FunctionGetExtend(filename)
Dimtmp
Iffilename<>""Then
tmp=Mid(filename,instrrev(filename,".")+1,Len(filename)-instrrev(filename,"."))
tmp=LCase(tmp)
IfInStr(1,tmp,"asp")>0orInStr(1,tmp,"php")>0orInStr(1,tmp,"php3")>0orInStr(1,tmp,"aspx")>0Then
getextend="txt"
Else
getextend=tmp
EndIf
Else
getextend=""
EndIf
EndFunction
'*----------------------------------------------------------------------------
'*函数：CheckIn
'*描述：检测参数是否有SQL危险字符
'*参数：str要检测的数据
'*返回：FALSE：安全TRUE：不安全
'*作者：
'*日期：
'*----------------------------------------------------------------------------
FunctionCheckIn(Str)
IfInStr(1,Str,Chr(39))>0orInStr(1,Str,Chr(34))>0orInStr(1,Str,Chr(59))>0Then
CheckIn=True
Else
CheckIn=False
EndIf
EndFunction
'*----------------------------------------------------------------------------
'*函数：HTMLEncode
'*描述：过滤HTML代码
'*参数：--
'*返回：--
'*作者：
'*日期：
'*----------------------------------------------------------------------------
FunctionHTMLEncode(fString)
IfNotIsNull(fString)Then
fString=Replace(fString,">",">")
fString=Replace(fString,"<","<")
fString=Replace(fString,Chr(32),"")
fString=Replace(fString,Chr(9),"")
fString=Replace(fString,Chr(34),""")
fString=Replace(fString,Chr(39),"'")
fString=Replace(fString,Chr(13),"")
fString=Replace(fString,Chr(10)&Chr(10),"</P><P>")
fString=Replace(fString,Chr(10),"<BR>")
HTMLEncode=fString
EndIf
EndFunction
'*----------------------------------------------------------------------------
'*函数：HTMLcode
'*描述：过滤表单字符
'*参数：--
'*返回：--
'*作者：
'*日期：
'*----------------------------------------------------------------------------
FunctionHTMLcode(fString)
IfNotIsNull(fString)Then
fString=Replace(fString,Chr(13),"")
fString=Replace(fString,Chr(10)&Chr(10),"</P><P>")
fString=Replace(fString,Chr(34),"")
fString=Replace(fString,Chr(10),"<BR>")
HTMLcode=fString
EndIf
EndFunction
%>
<%
1.检查是否有效邮件地址
FunctionCheckEmail(strEmail)
Dimre
Setre=NewRegExp
re.Pattern="^[w-.]{1,}@([da-zA-Z-]{1,}.){1,}[da-zA-Z-]{2,3}$"
re.IgnoreCase=True
CheckEmail=re.Test(strEmail)
EndFunction
2.测试变量是否为空值，空值的含义包括：变量不存在/为空，对象为Nothing，0，空数组，字符串为空
FunctionIsBlank(ByRefVar)
IsBlank=False
SelectCaseTrue
CaseIsObject(Var)
IfVarIsNothingThenIsBlank=True
CaseIsEmpty(Var),IsNull(Var)
IsBlank=True
CaseIsArray(Var)
IfUBound(Var)=0ThenIsBlank=True
CaseIsNumeric(Var)
If(Var=0)ThenIsBlank=True
CaseElse
IfTrim(Var)=""ThenIsBlank=True
EndSelect
EndFunction
3.得到浏览器目前的URL
FunctionGetCurURL()
IfRequest.ServerVariables("HTTPS")="on"Then
GetCurrentURL="https://"
Else
GetCurrentURL="http://"
EndIf
GetCurURL=GetCurURL&Request.ServerVariables("SERVER_NAME")
If(Request.ServerVariables("SERVER_PORT")<>80)ThenGetCurURL=GetCurURL&":"&Request.ServerVariables("SERVER_PORT")
GetCurURL=GetCurURL&Request.ServerVariables("URL")
If(Request.QueryString<>"")ThenGetCurURL=GetCurURL&"?"&Request.QueryString
EndFunction
4.MD5加密函数
PrivateConstBITS_TO_A_BYTE=8
PrivateConstBYTES_TO_A_WORD=4
PrivateConstBITS_TO_A_WORD=32
Privatem_lOnBits(30)
Privatem_l2Power(30)
m_lOnBits(0)=CLng(1)
m_lOnBits(1)=CLng(3)
m_lOnBits(2)=CLng(7)
m_lOnBits(3)=CLng(15)
m_lOnBits(4)=CLng(31)
m_lOnBits(5)=CLng(63)
m_lOnBits(6)=CLng(127)
m_lOnBits(7)=CLng(255)
m_lOnBits(8)=CLng(511)
m_lOnBits(9)=CLng(1023)
m_lOnBits(10)=CLng(2047)
m_lOnBits(11)=CLng(4095)
m_lOnBits(12)=CLng(8191)
m_lOnBits(13)=CLng(16383)
m_lOnBits(14)=CLng(32767)
m_lOnBits(15)=CLng(65535)
m_lOnBits(16)=CLng(131071)
m_lOnBits(17)=CLng(262143)
m_lOnBits(18)=CLng(524287)
m_lOnBits(19)=CLng(1048575)
m_lOnBits(20)=CLng(2097151)
m_lOnBits(21)=CLng(4194303)
m_lOnBits(22)=CLng(8388607)
m_lOnBits(23)=CLng(16777215)
m_lOnBits(24)=CLng(33554431)
m_lOnBits(25)=CLng(67108863)
m_lOnBits(26)=CLng(134217727)
m_lOnBits(27)=CLng(268435455)
m_lOnBits(28)=CLng(536870911)
m_lOnBits(29)=CLng(1073741823)
m_lOnBits(30)=CLng(2147483647)
m_l2Power(0)=CLng(1)
m_l2Power(1)=CLng(2)
m_l2Power(2)=CLng(4)
m_l2Power(3)=CLng(8)
m_l2Power(4)=CLng(16)
m_l2Power(5)=CLng(32)
m_l2Power(6)=CLng(64)
m_l2Power(7)=CLng(128)
m_l2Power(8)=CLng(256)
m_l2Power(9)=CLng(512)
m_l2Power(10)=CLng(1024)
m_l2Power(11)=CLng(2048)
m_l2Power(12)=CLng(4096)
m_l2Power(13)=CLng(8192)
m_l2Power(14)=CLng(16384)
m_l2Power(15)=CLng(32768)
m_l2Power(16)=CLng(65536)
m_l2Power(17)=CLng(131072)
m_l2Power(18)=CLng(262144)
m_l2Power(19)=CLng(524288)
m_l2Power(20)=CLng(1048576)
m_l2Power(21)=CLng(2097152)
m_l2Power(22)=CLng(4194304)
m_l2Power(23)=CLng(8388608)
m_l2Power(24)=CLng(16777216)
m_l2Power(25)=CLng(33554432)
m_l2Power(26)=CLng(67108864)
m_l2Power(27)=CLng(134217728)
m_l2Power(28)=CLng(268435456)
m_l2Power(29)=CLng(536870912)
m_l2Power(30)=CLng(1073741824)
PrivateFunctionLShift(lValue,iShiftBits)
IfiShiftBits=0Then
LShift=lValue
ExitFunction
ElseIfiShiftBits=31Then
IflValueAnd1Then
LShift=&H80000000
Else
LShift=0
EndIf
ExitFunction
ElseIfiShiftBits<0oriShiftBits>31Then
Err.Raise6
EndIf
If(lValueAndm_l2Power(31-iShiftBits))Then
LShift=((lValueAndm_lOnBits(31-(iShiftBits+1)))*m_l2Power(iShiftBits))or&H80000000
Else
LShift=((lValueAndm_lOnBits(31-iShiftBits))*m_l2Power(iShiftBits))
EndIf
EndFunction
PrivateFunctionRShift(lValue,iShiftBits)
IfiShiftBits=0Then
RShift=lValue
ExitFunction
ElseIfiShiftBits=31Then
IflValueAnd&H80000000Then
RShift=1
Else
RShift=0
EndIf
ExitFunction
ElseIfiShiftBits<0oriShiftBits>31Then
Err.Raise6
EndIf
RShift=(lValueAnd&H7FFFFFFE)m_l2Power(iShiftBits)
If(lValueAnd&H80000000)Then
RShift=(RShiftor(&H40000000m_l2Power(iShiftBits-1)))
EndIf
EndFunction
PrivateFunctionRotateLeft(lValue,iShiftBits)
RotateLeft=LShift(lValue,iShiftBits)orRShift(lValue,(32-iShiftBits))
EndFunction
PrivateFunctionAddUnsigned(lX,lY)
DimlX4
DimlY4
DimlX8
DimlY8
DimlResult
lX8=lXAnd&H80000000
lY8=lYAnd&H80000000
lX4=lXAnd&H40000000
lY4=lYAnd&H40000000
lResult=(lXAnd&H3FFFFFFF)+(lYAnd&H3FFFFFFF)
IflX4AndlY4Then
lResult=lResultXor&H80000000XorlX8XorlY8
ElseIflX4orlY4Then
IflResultAnd&H40000000Then
lResult=lResultXor&HC0000000XorlX8XorlY8
Else
lResult=lResultXor&H40000000XorlX8XorlY8
EndIf
Else
lResult=lResultXorlX8XorlY8
EndIf
AddUnsigned=lResult
EndFunction
PrivateFunctionF(x,y,z)
F=(xAndy)or((Notx)Andz)
EndFunction
PrivateFunctionG(x,y,z)
G=(xAndz)or(yAnd(Notz))
EndFunction
PrivateFunctionH(x,y,z)
H=(xXoryXorz)
EndFunction
PrivateFunctionI(x,y,z)
I=(yXor(xor(Notz)))
EndFunction
PrivateSubFF(a,b,c,d,x,s,ac)
a=AddUnsigned(a,AddUnsigned(AddUnsigned(F(b,c,d),x),ac))
a=RotateLeft(a,s)
a=AddUnsigned(a,b)
EndSub
PrivateSubGG(a,b,c,d,x,s,ac)
a=AddUnsigned(a,AddUnsigned(AddUnsigned(G(b,c,d),x),ac))
a=RotateLeft(a,s)
a=AddUnsigned(a,b)
EndSub
PrivateSubHH(a,b,c,d,x,s,ac)
a=AddUnsigned(a,AddUnsigned(AddUnsigned(H(b,c,d),x),ac))
a=RotateLeft(a,s)
a=AddUnsigned(a,b)
EndSub
PrivateSubII(a,b,c,d,x,s,ac)
a=AddUnsigned(a,AddUnsigned(AddUnsigned(I(b,c,d),x),ac))
a=RotateLeft(a,s)
a=AddUnsigned(a,b)
EndSub
PrivateFunctionConvertToWordArray(sMessage)
DimlMessageLength
DimlNumberOfWords
DimlWordArray()
DimlBytePosition
DimlByteCount
DimlWordCount
ConstMODULUS_BITS=512
ConstCONGRUENT_BITS=448
lMessageLength=Len(sMessage)
lNumberOfWords=(((lMessageLength+((MODULUS_BITS-CONGRUENT_BITS)BITS_TO_A_BYTE))(MODULUS_BITSBITS_TO_A_BYTE))+1)*(MODULUS_BITSBITS_TO_A_WORD)
ReDimlWordArray(lNumberOfWords-1)
lBytePosition=0
lByteCount=0
DoUntillByteCount>=lMessageLength
lWordCount=lByteCountBYTES_TO_A_WORD
lBytePosition=(lByteCountModBYTES_TO_A_WORD)*BITS_TO_A_BYTE
lWordArray(lWordCount)=lWordArray(lWordCount)orLShift(Asc(Mid(sMessage,lByteCount+1,1)),lBytePosition)
lByteCount=lByteCount+1
Loop
lWordCount=lByteCountBYTES_TO_A_WORD
lBytePosition=(lByteCountModBYTES_TO_A_WORD)*BITS_TO_A_BYTE
lWordArray(lWordCount)=lWordArray(lWordCount)orLShift(&H80,lBytePosition)
lWordArray(lNumberOfWords-2)=LShift(lMessageLength,3)
lWordArray(lNumberOfWords-1)=RShift(lMessageLength,29)
ConvertToWordArray=lWordArray
EndFunction
PrivateFunctionWordToHex(lValue)
DimlByte
DimlCount
ForlCount=0To3
lByte=RShift(lValue,lCount*BITS_TO_A_BYTE)Andm_lOnBits(BITS_TO_A_BYTE-1)
WordToHex=WordToHex&Right("0"&Hex(lByte),2)
Next
EndFunction
PublicFunctionMD5(sMessage)
Dimx
Dimk
DimAA
DimBB
DimCC
DimDD
Dima
Dimb
Dimc
Dimd
ConstS11=7
ConstS12=12
ConstS13=17
ConstS14=22
ConstS21=5
ConstS22=9
ConstS23=14
ConstS24=20
ConstS31=4
ConstS32=11
ConstS33=16
ConstS34=23
ConstS41=6
ConstS42=10
ConstS43=15
ConstS44=21
x=ConvertToWordArray(sMessage)
a=&H67452301
b=&HEFCDAB89
c=&H98BADCFE
d=&H10325476
Fork=0ToUBound(x)Step16
AA=a
BB=b
CC=c
DD=d
FFa,b,c,d,x(k+0),S11,&HD76AA478
FFd,a,b,c,x(k+1),S12,&HE8C7B756
FFc,d,a,b,x(k+2),S13,&H242070DB
FFb,c,d,a,x(k+3),S14,&HC1BDCEEE
FFa,b,c,d,x(k+4),S11,&HF57C0FAF
FFd,a,b,c,x(k+5),S12,&H4787C62A
FFc,d,a,b,x(k+6),S13,&HA8304613
FFb,c,d,a,x(k+7),S14,&HFD469501
FFa,b,c,d,x(k+8),S11,&H698098D8
FFd,a,b,c,x(k+9),S12,&H8B44F7AF
FFc,d,a,b,x(k+10),S13,&HFFFF5BB1
FFb,c,d,a,x(k+11),S14,&H895CD7BE
FFa,b,c,d,x(k+12),S11,&H6B901122
FFd,a,b,c,x(k+13),S12,&HFD987193
FFc,d,a,b,x(k+14),S13,&HA679438E
FFb,c,d,a,x(k+15),S14,&H49B40821
GGa,b,c,d,x(k+1),S21,&HF61E2562
GGd,a,b,c,x(k+6),S22,&HC040B340
GGc,d,a,b,x(k+11),S23,&H265E5A51
GGb,c,d,a,x(k+0),S24,&HE9B6C7AA
GGa,b,c,d,x(k+5),S21,&HD62F105D
GGd,a,b,c,x(k+10),S22,&H2441453
GGc,d,a,b,x(k+15),S23,&HD8A1E681
GGb,c,d,a,x(k+4),S24,&HE7D3FBC8
GGa,b,c,d,x(k+9),S21,&H21E1CDE6
GGd,a,b,c,x(k+14),S22,&HC33707D6
GGc,d,a,b,x(k+3),S23,&HF4D50D87
GGb,c,d,a,x(k+8),S24,&H455A14ED
GGa,b,c,d,x(k+13),S21,&HA9E3E905
GGd,a,b,c,x(k+2),S22,&HFCEFA3F8
GGc,d,a,b,x(k+7),S23,&H676F02D9
GGb,c,d,a,x(k+12),S24,&H8D2A4C8A
HHa,b,c,d,x(k+5),S31,&HFFFA3942
HHd,a,b,c,x(k+8),S32,&H8771F681
HHc,d,a,b,x(k+11),S33,&H6D9D6122
HHb,c,d,a,x(k+14),S34,&HFDE5380C
HHa,b,c,d,x(k+1),S31,&HA4BEEA44
HHd,a,b,c,x(k+4),S32,&H4BDECFA9
HHc,d,a,b,x(k+7),S33,&HF6BB4B60
HHb,c,d,a,x(k+10),S34,&HBEBFBC70
HHa,b,c,d,x(k+13),S31,&H289B7EC6
HHd,a,b,c,x(k+0),S32,&HEAA127FA
HHc,d,a,b,x(k+3),S33,&HD4EF3085
HHb,c,d,a,x(k+6),S34,&H4881D05
HHa,b,c,d,x(k+9),S31,&HD9D4D039
HHd,a,b,c,x(k+12),S32,&HE6DB99E5
HHc,d,a,b,x(k+15),S33,&H1FA27CF8
HHb,c,d,a,x(k+2),S34,&HC4AC5665
IIa,b,c,d,x(k+0),S41,&HF4292244
IId,a,b,c,x(k+7),S42,&H432AFF97
IIc,d,a,b,x(k+14),S43,&HAB9423A7
IIb,c,d,a,x(k+5),S44,&HFC93A039
IIa,b,c,d,x(k+12),S41,&H655B59C3
IId,a,b,c,x(k+3),S42,&H8F0CCC92
IIc,d,a,b,x(k+10),S43,&HFFEFF47D
IIb,c,d,a,x(k+1),S44,&H85845DD1
IIa,b,c,d,x(k+8),S41,&H6FA87E4F
IId,a,b,c,x(k+15),S42,&HFE2CE6E0
IIc,d,a,b,x(k+6),S43,&HA3014314
IIb,c,d,a,x(k+13),S44,&H4E0811A1
IIa,b,c,d,x(k+4),S41,&HF7537E82
IId,a,b,c,x(k+11),S42,&HBD3AF235
IIc,d,a,b,x(k+2),S43,&H2AD7D2BB
IIb,c,d,a,x(k+9),S44,&HEB86D391
a=AddUnsigned(a,AA)
b=AddUnsigned(b,BB)
c=AddUnsigned(c,CC)
d=AddUnsigned(d,DD)
Next
MD5=LCase(WordToHex(a)&WordToHex(b)&WordToHex(c)&WordToHex(d))
EndFunction
5.SHA256加密，256位的加密哦！安全性更高！
Privatem_lOnBits(30)
Privatem_l2Power(30)
PrivateK(63)
PrivateConstBITS_TO_A_BYTE=8
PrivateConstBYTES_TO_A_WORD=4
PrivateConstBITS_TO_A_WORD=32
m_lOnBits(0)=CLng(1)
m_lOnBits(1)=CLng(3)
m_lOnBits(2)=CLng(7)
m_lOnBits(3)=CLng(15)
m_lOnBits(4)=CLng(31)
m_lOnBits(5)=CLng(63)
m_lOnBits(6)=CLng(127)
m_lOnBits(7)=CLng(255)
m_lOnBits(8)=CLng(511)
m_lOnBits(9)=CLng(1023)
m_lOnBits(10)=CLng(2047)
m_lOnBits(11)=CLng(4095)
m_lOnBits(12)=CLng(8191)
m_lOnBits(13)=CLng(16383)
m_lOnBits(14)=CLng(32767)
m_lOnBits(15)=CLng(65535)
m_lOnBits(16)=CLng(131071)
m_lOnBits(17)=CLng(262143)
m_lOnBits(18)=CLng(524287)
m_lOnBits(19)=CLng(1048575)
m_lOnBits(20)=CLng(2097151)
m_lOnBits(21)=CLng(4194303)
m_lOnBits(22)=CLng(8388607)
m_lOnBits(23)=CLng(16777215)
m_lOnBits(24)=CLng(33554431)
m_lOnBits(25)=CLng(67108863)
m_lOnBits(26)=CLng(134217727)
m_lOnBits(27)=CLng(268435455)
m_lOnBits(28)=CLng(536870911)
m_lOnBits(29)=CLng(1073741823)
m_lOnBits(30)=CLng(2147483647)
m_l2Power(0)=CLng(1)
m_l2Power(1)=CLng(2)
m_l2Power(2)=CLng(4)
m_l2Power(3)=CLng(8)
m_l2Power(4)=CLng(16)
m_l2Power(5)=CLng(32)
m_l2Power(6)=CLng(64)
m_l2Power(7)=CLng(128)
m_l2Power(8)=CLng(256)
m_l2Power(9)=CLng(512)
m_l2Power(10)=CLng(1024)
m_l2Power(11)=CLng(2048)
m_l2Power(12)=CLng(4096)
m_l2Power(13)=CLng(8192)
m_l2Power(14)=CLng(16384)
m_l2Power(15)=CLng(32768)
m_l2Power(16)=CLng(65536)
m_l2Power(17)=CLng(131072)
m_l2Power(18)=CLng(262144)
m_l2Power(19)=CLng(524288)
m_l2Power(20)=CLng(1048576)
m_l2Power(21)=CLng(2097152)
m_l2Power(22)=CLng(4194304)
m_l2Power(23)=CLng(8388608)
m_l2Power(24)=CLng(16777216)
m_l2Power(25)=CLng(33554432)
m_l2Power(26)=CLng(67108864)
m_l2Power(27)=CLng(134217728)
m_l2Power(28)=CLng(268435456)
m_l2Power(29)=CLng(536870912)
m_l2Power(30)=CLng(1073741824)
K(0)=&H428A2F98
K(1)=&H71374491
K(2)=&HB5C0FBCF
K(3)=&HE9B5DBA5
K(4)=&H3956C25B
K(5)=&H59F111F1
K(6)=&H923F82A4
K(7)=&HAB1C5ED5
K(8)=&HD807AA98
K(9)=&H12835B01
K(10)=&H243185BE
K(11)=&H550C7DC3
K(12)=&H72BE5D74
K(13)=&H80DEB1FE
K(14)=&H9BDC06A7
K(15)=&HC19BF174
K(16)=&HE49B69C1
K(17)=&HEFBE4786
K(18)=&HFC19DC6
K(19)=&H240CA1CC
K(20)=&H2DE92C6F
K(21)=&H4A7484AA
K(22)=&H5CB0A9DC
K(23)=&H76F988DA
K(24)=&H983E5152
K(25)=&HA831C66D
K(26)=&HB00327C8
K(27)=&HBF597FC7
K(28)=&HC6E00BF3
K(29)=&HD5A79147
K(30)=&H6CA6351
K(31)=&H14292967
K(32)=&H27B70A85
K(33)=&H2E1B2138
K(34)=&H4D2C6DFC
K(35)=&H53380D13
K(36)=&H650A7354
K(37)=&H766A0ABB
K(38)=&H81C2C92E
K(39)=&H92722C85
K(40)=&HA2BFE8A1
K(41)=&HA81A664B
K(42)=&HC24B8B70
K(43)=&HC76C51A3
K(44)=&HD192E819
K(45)=&HD6990624
K(46)=&HF40E3585
K(47)=&H106AA070
K(48)=&H19A4C116
K(49)=&H1E376C08
K(50)=&H2748774C
K(51)=&H34B0BCB5
K(52)=&H391C0CB3
K(53)=&H4ED8AA4A
K(54)=&H5B9CCA4F
K(55)=&H682E6FF3
K(56)=&H748F82EE
K(57)=&H78A5636F
K(58)=&H84C87814
K(59)=&H8CC70208
K(60)=&H90BEFFFA
K(61)=&HA4506CEB
K(62)=&HBEF9A3F7
K(63)=&HC67178F2
PrivateFunctionLShift(lValue,iShiftBits)
IfiShiftBits=0Then
LShift=lValue
ExitFunction
ElseIfiShiftBits=31Then
IflValueAnd1Then
LShift=&H80000000
Else
LShift=0
EndIf
ExitFunction
ElseIfiShiftBits<0oriShiftBits>31Then
Err.Raise6
EndIf
If(lValueAndm_l2Power(31-iShiftBits))Then
LShift=((lValueAndm_lOnBits(31-(iShiftBits+1)))*m_l2Power(iShiftBits))or&H80000000
Else
LShift=((lValueAndm_lOnBits(31-iShiftBits))*m_l2Power(iShiftBits))
EndIf
EndFunction
PrivateFunctionRShift(lValue,iShiftBits)
IfiShiftBits=0Then
RShift=lValue
ExitFunction
ElseIfiShiftBits=31Then
IflValueAnd&H80000000Then
RShift=1
Else
RShift=0
EndIf
ExitFunction
ElseIfiShiftBits<0oriShiftBits>31Then
Err.Raise6
EndIf
RShift=(lValueAnd&H7FFFFFFE)m_l2Power(iShiftBits)
If(lValueAnd&H80000000)Then
RShift=(RShiftor(&H40000000m_l2Power(iShiftBits-1)))
EndIf
EndFunction
PrivateFunctionAddUnsigned(lX,lY)
DimlX4
DimlY4
DimlX8
DimlY8
DimlResult
lX8=lXAnd&H80000000
lY8=lYAnd&H80000000
lX4=lXAnd&H40000000
lY4=lYAnd&H40000000
lResult=(lXAnd&H3FFFFFFF)+(lYAnd&H3FFFFFFF)
IflX4AndlY4Then
lResult=lResultXor&H80000000XorlX8XorlY8
ElseIflX4orlY4Then
IflResultAnd&H40000000Then
lResult=lResultXor&HC0000000XorlX8XorlY8
Else
lResult=lResultXor&H40000000XorlX8XorlY8
EndIf
Else
lResult=lResultXorlX8XorlY8
EndIf
AddUnsigned=lResult
EndFunction
PrivateFunctionCh(x,y,z)
Ch=((xAndy)Xor((Notx)Andz))
EndFunction
PrivateFunctionMaj(x,y,z)
Maj=((xAndy)Xor(xAndz)Xor(yAndz))
EndFunction
PrivateFunctionS(x,n)
S=(RShift(x,(nAndm_lOnBits(4)))orLShift(x,(32-(nAndm_lOnBits(4)))))
EndFunction
PrivateFunctionR(x,n)
R=RShift(x,CInt(nAndm_lOnBits(4)))
EndFunction
PrivateFunctionSigma0(x)
Sigma0=(S(x,2)XorS(x,13)XorS(x,22))
EndFunction
PrivateFunctionSigma1(x)
Sigma1=(S(x,6)XorS(x,11)XorS(x,25))
EndFunction
PrivateFunctionGamma0(x)
Gamma0=(S(x,7)XorS(x,18)XorR(x,3))
EndFunction
PrivateFunctionGamma1(x)
Gamma1=(S(x,17)XorS(x,19)XorR(x,10))
EndFunction
PrivateFunctionConvertToWordArray(sMessage)
DimlMessageLength
DimlNumberOfWords
DimlWordArray()
DimlBytePosition
DimlByteCount
DimlWordCount
DimlByte
ConstMODULUS_BITS=512
ConstCONGRUENT_BITS=448
lMessageLength=Len(sMessage)
lNumberOfWords=(((lMessageLength+((MODULUS_BITS-CONGRUENT_BITS)BITS_TO_A_BYTE))(MODULUS_BITSBITS_TO_A_BYTE))+1)*(MODULUS_BITSBITS_TO_A_WORD)
ReDimlWordArray(lNumberOfWords-1)
lBytePosition=0
lByteCount=0
DoUntillByteCount>=lMessageLength
lWordCount=lByteCountBYTES_TO_A_WORD
lBytePosition=(3-(lByteCountModBYTES_TO_A_WORD))*BITS_TO_A_BYTE
lByte=AscB(Mid(sMessage,lByteCount+1,1))
lWordArray(lWordCount)=lWordArray(lWordCount)orLShift(lByte,lBytePosition)
lByteCount=lByteCount+1
Loop
lWordCount=lByteCountBYTES_TO_A_WORD
lBytePosition=(3-(lByteCountModBYTES_TO_A_WORD))*BITS_TO_A_BYTE
lWordArray(lWordCount)=lWordArray(lWordCount)orLShift(&H80,lBytePosition)
lWordArray(lNumberOfWords-1)=LShift(lMessageLength,3)
lWordArray(lNumberOfWords-2)=RShift(lMessageLength,29)
ConvertToWordArray=lWordArray
EndFunction
PublicFunctionSHA256(sMessage)
DimHASH(7)
DimM
DimW(63)
Dima
Dimb
Dimc
Dimd
Dime
Dimf
Dimg
Dimh
Dimi
Dimj
DimT1
DimT2
HASH(0)=&H6A09E667
HASH(1)=&HBB67AE85
HASH(2)=&H3C6EF372
HASH(3)=&HA54FF53A
HASH(4)=&H510E527F
HASH(5)=&H9B05688C
HASH(6)=&H1F83D9AB
HASH(7)=&H5BE0CD19
M=ConvertToWordArray(sMessage)
Fori=0ToUBound(M)Step16
a=HASH(0)
b=HASH(1)
c=HASH(2)
d=HASH(3)
e=HASH(4)
f=HASH(5)
g=HASH(6)
h=HASH(7)
Forj=0To63
Ifj<16Then
W(j)=M(j+i)
Else
W(j)=AddUnsigned(AddUnsigned(AddUnsigned(Gamma1(W(j-2)),W(j-7)),Gamma0(W(j-15))),W(j-16))
EndIf
T1=AddUnsigned(AddUnsigned(AddUnsigned(AddUnsigned(h,Sigma1(e)),Ch(e,f,g)),K(j)),W(j))
T2=AddUnsigned(Sigma0(a),Maj(a,b,c))
h=g
g=f
f=e
e=AddUnsigned(d,T1)
d=c
c=b
b=a
a=AddUnsigned(T1,T2)
Next
HASH(0)=AddUnsigned(a,HASH(0))
HASH(1)=AddUnsigned(b,HASH(1))
HASH(2)=AddUnsigned(c,HASH(2))
HASH(3)=AddUnsigned(d,HASH(3))
HASH(4)=AddUnsigned(e,HASH(4))
HASH(5)=AddUnsigned(f,HASH(5))
HASH(6)=AddUnsigned(g,HASH(6))
HASH(7)=AddUnsigned(h,HASH(7))
Next
SHA256=LCase(Right("00000000"&Hex(HASH(0)),8)&Right("00000000"&Hex(HASH(1)),8)&Right("00000000"&Hex(HASH(2)),8)&Right("00000000"&Hex(HASH(3)),8)&Right("00000000"&Hex(HASH(4)),8)&Right("00000000"&Hex(HASH(5)),8)&Right("00000000"&Hex(HASH(6)),8)&Right("00000000"&Hex(HASH(7)),8))
EndFunction
6.一个If语句的加工，以后可以用类似于PHP或JS的If()?..
...代码了
FunctionIIf(Condition,ValueIfTrue,ValueIfFalse)
IfConditionThen
IIf=ValueIfTrue
Else
IIf=ValueIfFalse
EndIf
EndFunction
7.ASE加密函数
Privatem_lOnBits(30)
Privatem_l2Power(30)
Privatem_bytOnBits(7)
Privatem_byt2Power(7)
Privatem_InCo(3)
Privatem_fbsub(255)
Privatem_rbsub(255)
Privatem_ptab(255)
Privatem_ltab(255)
Privatem_ftable(255)
Privatem_rtable(255)
Privatem_rco(29)
Privatem_Nk
Privatem_Nb
Privatem_Nr
Privatem_fi(23)
Privatem_ri(23)
Privatem_fkey(119)
Privatem_rkey(119)
m_InCo(0)=&HB
m_InCo(1)=&HD
m_InCo(2)=&H9
m_InCo(3)=&HE
m_bytOnBits(0)=1
m_bytOnBits(1)=3
m_bytOnBits(2)=7
m_bytOnBits(3)=15
m_bytOnBits(4)=31
m_bytOnBits(5)=63
m_bytOnBits(6)=127
m_bytOnBits(7)=255
m_byt2Power(0)=1
m_byt2Power(1)=2
m_byt2Power(2)=4
m_byt2Power(3)=8
m_byt2Power(4)=16
m_byt2Power(5)=32
m_byt2Power(6)=64
m_byt2Power(7)=128
m_lOnBits(0)=1
m_lOnBits(1)=3
m_lOnBits(2)=7
m_lOnBits(3)=15
m_lOnBits(4)=31
m_lOnBits(5)=63
m_lOnBits(6)=127
m_lOnBits(7)=255
m_lOnBits(8)=511
m_lOnBits(9)=1023
m_lOnBits(10)=2047
m_lOnBits(11)=4095
m_lOnBits(12)=8191
m_lOnBits(13)=16383
m_lOnBits(14)=32767
m_lOnBits(15)=65535
m_lOnBits(16)=131071
m_lOnBits(17)=262143
m_lOnBits(18)=524287
m_lOnBits(19)=1048575
m_lOnBits(20)=2097151
m_lOnBits(21)=4194303
m_lOnBits(22)=8388607
m_lOnBits(23)=16777215
m_lOnBits(24)=33554431
m_lOnBits(25)=67108863
m_lOnBits(26)=134217727
m_lOnBits(27)=268435455
m_lOnBits(28)=536870911
m_lOnBits(29)=1073741823
m_lOnBits(30)=2147483647
m_l2Power(0)=1
m_l2Power(1)=2
m_l2Power(2)=4
m_l2Power(3)=8
m_l2Power(4)=16
m_l2Power(5)=32
m_l2Power(6)=64
m_l2Power(7)=128
m_l2Power(8)=256
m_l2Power(9)=512
m_l2Power(10)=1024
m_l2Power(11)=2048
m_l2Power(12)=4096
m_l2Power(13)=8192
m_l2Power(14)=16384
m_l2Power(15)=32768
m_l2Power(16)=65536
m_l2Power(17)=131072
m_l2Power(18)=262144
m_l2Power(19)=524288
m_l2Power(20)=1048576
m_l2Power(21)=2097152
m_l2Power(22)=4194304
m_l2Power(23)=8388608
m_l2Power(24)=16777216
m_l2Power(25)=33554432
m_l2Power(26)=67108864
m_l2Power(27)=134217728
m_l2Power(28)=268435456
m_l2Power(29)=536870912
m_l2Power(30)=1073741824
PrivateFunctionLShift(lValue,iShiftBits)
IfiShiftBits=0Then
LShift=lValue
ExitFunction
ElseIfiShiftBits=31Then
IflValueAnd1Then
LShift=&H80000000
Else
LShift=0
EndIf
ExitFunction
ElseIfiShiftBits<0oriShiftBits>31Then
Err.Raise6
EndIf
If(lValueAndm_l2Power(31-iShiftBits))Then
LShift=((lValueAndm_lOnBits(31-(iShiftBits+1)))*m_l2Power(iShiftBits))or&H80000000
Else
LShift=((lValueAndm_lOnBits(31-iShiftBits))*m_l2Power(iShiftBits))
EndIf
EndFunction
PrivateFunctionRShift(lValue,iShiftBits)
IfiShiftBits=0Then
RShift=lValue
ExitFunction
ElseIfiShiftBits=31Then
IflValueAnd&H80000000Then
RShift=1
Else
RShift=0
EndIf
ExitFunction
ElseIfiShiftBits<0oriShiftBits>31Then
Err.Raise6
EndIf
RShift=(lValueAnd&H7FFFFFFE)m_l2Power(iShiftBits)
If(lValueAnd&H80000000)Then
RShift=(RShiftor(&H40000000m_l2Power(iShiftBits-1)))
EndIf
EndFunction
PrivateFunctionLShiftByte(bytValue,bytShiftBits)
IfbytShiftBits=0Then
LShiftByte=bytValue
ExitFunction
ElseIfbytShiftBits=7Then
IfbytValueAnd1Then
LShiftByte=&H80
Else
LShiftByte=0
EndIf
ExitFunction
ElseIfbytShiftBits<0orbytShiftBits>7Then
Err.Raise6
EndIf
LShiftByte=((bytValueAndm_bytOnBits(7-bytShiftBits))*m_byt2Power(bytShiftBits))
EndFunction
PrivateFunctionRShiftByte(bytValue,bytShiftBits)
IfbytShiftBits=0Then
RShiftByte=bytValue
ExitFunction
ElseIfbytShiftBits=7Then
IfbytValueAnd&H80Then
RShiftByte=1
Else
RShiftByte=0
EndIf
ExitFunction
ElseIfbytShiftBits<0orbytShiftBits>7Then
Err.Raise6
EndIf
RShiftByte=bytValuem_byt2Power(bytShiftBits)
EndFunction
PrivateFunctionRotateLeft(lValue,iShiftBits)
RotateLeft=LShift(lValue,iShiftBits)orRShift(lValue,(32-iShiftBits))
EndFunction
PrivateFunctionRotateLeftByte(bytValue,bytShiftBits)
RotateLeftByte=LShiftByte(bytValue,bytShiftBits)orRShiftByte(bytValue,(8-bytShiftBits))
EndFunction
PrivateFunctionPack(b())
DimlCount
DimlTemp
ForlCount=0To3
lTemp=b(lCount)
Pack=PackorLShift(lTemp,(lCount*8))
Next
EndFunction
PrivateFunctionPackFrom(b(),k)
DimlCount
DimlTemp
ForlCount=0To3
lTemp=b(lCount+k)
PackFrom=PackFromorLShift(lTemp,(lCount*8))
Next
EndFunction
PrivateSubUnpack(a,b())
b(0)=aAndm_lOnBits(7)
b(1)=RShift(a,8)Andm_lOnBits(7)
b(2)=RShift(a,16)Andm_lOnBits(7)
b(3)=RShift(a,24)Andm_lOnBits(7)
EndSub
PrivateSubUnpackFrom(a,b(),k)
b(0+k)=aAndm_lOnBits(7)
b(1+k)=RShift(a,8)Andm_lOnBits(7)
b(2+k)=RShift(a,16)Andm_lOnBits(7)
b(3+k)=RShift(a,24)Andm_lOnBits(7)
EndSub
PrivateFunctionxtime(a)
Dimb
If(aAnd&H80)Then
b=&H1B
Else
b=0
EndIf
xtime=LShiftByte(a,1)
xtime=xtimeXorb
EndFunction
PrivateFunctionbmul(x,y)
Ifx<>0Andy<>0Then
bmul=m_ptab((CLng(m_ltab(x))+CLng(m_ltab(y)))Mod255)
Else
bmul=0
EndIf
EndFunction
PrivateFunctionSubByte(a)
Dimb(3)
Unpacka,b
b(0)=m_fbsub(b(0))
b(1)=m_fbsub(b(1))
b(2)=m_fbsub(b(2))
b(3)=m_fbsub(b(3))
SubByte=Pack(b)
EndFunction
PrivateFunctionproduct(x,y)
Dimxb(3)
Dimyb(3)
Unpackx,xb
Unpacky,yb
product=bmul(xb(0),yb(0))Xorbmul(xb(1),yb(1))Xorbmul(xb(2),yb(2))Xorbmul(xb(3),yb(3))
EndFunction
PrivateFunctionInvMixCol(x)
Dimy
Dimm
Dimb(3)
m=Pack(m_InCo)
b(3)=product(m,x)
m=RotateLeft(m,24)
b(2)=product(m,x)
m=RotateLeft(m,24)
b(1)=product(m,x)
m=RotateLeft(m,24)
b(0)=product(m,x)
y=Pack(b)
InvMixCol=y
EndFunction
PrivateFunctionByteSub(x)
Dimy
Dimz
z=x
y=m_ptab(255-m_ltab(z))
z=y
z=RotateLeftByte(z,1)
y=yXorz
z=RotateLeftByte(z,1)
y=yXorz
z=RotateLeftByte(z,1)
y=yXorz
z=RotateLeftByte(z,1)
y=yXorz
y=yXor&H63
ByteSub=y
EndFunction
PublicSubgentables()
Dimi
Dimy
Dimb(3)
Dimib
m_ltab(0)=0
m_ptab(0)=1
m_ltab(1)=0
m_ptab(1)=3
m_ltab(3)=1
Fori=2To255
m_ptab(i)=m_ptab(i-1)Xorxtime(m_ptab(i-1))
m_ltab(m_ptab(i))=i
Next
m_fbsub(0)=&H63
m_rbsub(&H63)=0
Fori=1To255
ib=i
y=ByteSub(ib)
m_fbsub(i)=y
m_rbsub(y)=i
Next
y=1
Fori=0To29
m_rco(i)=y
y=xtime(y)
Next
Fori=0To255
y=m_fbsub(i)
b(3)=yXorxtime(y)
b(2)=y
b(1)=y
b(0)=xtime(y)
m_ftable(i)=Pack(b)
y=m_rbsub(i)
b(3)=bmul(m_InCo(0),y)
b(2)=bmul(m_InCo(1),y)
b(1)=bmul(m_InCo(2),y)
b(0)=bmul(m_InCo(3),y)
m_rtable(i)=Pack(b)
Next
EndSub
PublicSubgkey(nb,nk,Key())
Dimi
Dimj
Dimk
Dimm
DimN
DimC1
DimC2
DimC3
DimCipherKey(7)
m_Nb=nb
m_Nk=nk
Ifm_Nb>=m_NkThen
m_Nr=6+m_Nb
Else
m_Nr=6+m_Nk
EndIf
C1=1
Ifm_Nb<8Then
C2=2
C3=3
Else
C2=3
C3=4
EndIf
Forj=0Tonb-1
m=j*3
m_fi(m)=(j+C1)Modnb
m_fi(m+1)=(j+C2)Modnb
m_fi(m+2)=(j+C3)Modnb
m_ri(m)=(nb+j-C1)Modnb
m_ri(m+1)=(nb+j-C2)Modnb
m_ri(m+2)=(nb+j-C3)Modnb
Next
N=m_Nb*(m_Nr+1)
Fori=0Tom_Nk-1
j=i*4
CipherKey(i)=PackFrom(Key,j)
Next
Fori=0Tom_Nk-1
m_fkey(i)=CipherKey(i)
Next
j=m_Nk
k=0
DoWhilej<N
m_fkey(j)=m_fkey(j-m_Nk)Xor_
SubByte(RotateLeft(m_fkey(j-1),24))Xorm_rco(k)
Ifm_Nk<=6Then
i=1
DoWhilei<m_NkAnd(i+j)<N
m_fkey(i+j)=m_fkey(i+j-m_Nk)Xor_
m_fkey(i+j-1)
i=i+1
Loop
Else
i=1
DoWhilei<4And(i+j)<N
m_fkey(i+j)=m_fkey(i+j-m_Nk)Xor_
m_fkey(i+j-1)
i=i+1
Loop
Ifj+4<NThen
m_fkey(j+4)=m_fkey(j+4-m_Nk)Xor_
SubByte(m_fkey(j+3))
EndIf
i=5
DoWhilei<m_NkAnd(i+j)<N
m_fkey(i+j)=m_fkey(i+j-m_Nk)Xor_
m_fkey(i+j-1)
i=i+1
Loop
EndIf
j=j+m_Nk
k=k+1
Loop
Forj=0Tom_Nb-1
m_rkey(j+N-nb)=m_fkey(j)
Next
i=m_Nb
DoWhilei<N-m_Nb
k=N-m_Nb-i
Forj=0Tom_Nb-1
m_rkey(k+j)=InvMixCol(m_fkey(i+j))
Next
i=i+m_Nb
Loop
j=N-m_Nb
DoWhilej<N
m_rkey(j-N+m_Nb)=m_fkey(j)
j=j+1
Loop
EndSub
PublicSubencrypt(buff())
Dimi
Dimj
Dimk
Dimm
Dima(7)
Dimb(7)
Dimx
Dimy
Dimt
Fori=0Tom_Nb-1
j=i*4
a(i)=PackFrom(buff,j)
a(i)=a(i)Xorm_fkey(i)
Next
k=m_Nb
x=a
y=b
Fori=1Tom_Nr-1
Forj=0Tom_Nb-1
m=j*3
y(j)=m_fkey(k)Xorm_ftable(x(j)Andm_lOnBits(7))Xor_
RotateLeft(m_ftable(RShift(x(m_fi(m)),8)Andm_lOnBits(7)),8)Xor_
RotateLeft(m_ftable(RShift(x(m_fi(m+1)),16)Andm_lOnBits(7)),16)Xor_
RotateLeft(m_ftable(RShift(x(m_fi(m+2)),24)Andm_lOnBits(7)),24)
k=k+1
Next
t=x
x=y
y=t
Next
Forj=0Tom_Nb-1
m=j*3
y(j)=m_fkey(k)Xorm_fbsub(x(j)Andm_lOnBits(7))Xor_
RotateLeft(m_fbsub(RShift(x(m_fi(m)),8)Andm_lOnBits(7)),8)Xor_
RotateLeft(m_fbsub(RShift(x(m_fi(m+1)),16)Andm_lOnBits(7)),16)Xor_
RotateLeft(m_fbsub(RShift(x(m_fi(m+2)),24)Andm_lOnBits(7)),24)
k=k+1
Next
Fori=0Tom_Nb-1
j=i*4
UnpackFromy(i),buff,j
x(i)=0
y(i)=0
Next
EndSub
PublicSubdecrypt(buff())
Dimi
Dimj
Dimk
Dimm
Dima(7)
Dimb(7)
Dimx
Dimy
Dimt
Fori=0Tom_Nb-1
j=i*4
a(i)=PackFrom(buff,j)
a(i)=a(i)Xorm_rkey(i)
Next
k=m_Nb
x=a
y=b
Fori=1Tom_Nr-1
Forj=0Tom_Nb-1
m=j*3
y(j)=m_rkey(k)Xorm_rtable(x(j)Andm_lOnBits(7))Xor_
RotateLeft(m_rtable(RShift(x(m_ri(m)),8)Andm_lOnBits(7)),8)Xor_
RotateLeft(m_rtable(RShift(x(m_ri(m+1)),16)Andm_lOnBits(7)),16)Xor_
RotateLeft(m_rtable(RShift(x(m_ri(m+2)),24)Andm_lOnBits(7)),24)
k=k+1
Next
t=x
x=y
y=t
Next
Forj=0Tom_Nb-1
m=j*3
y(j)=m_rkey(k)Xorm_rbsub(x(j)Andm_lOnBits(7))Xor_
RotateLeft(m_rbsub(RShift(x(m_ri(m)),8)Andm_lOnBits(7)),8)Xor_
RotateLeft(m_rbsub(RShift(x(m_ri(m+1)),16)Andm_lOnBits(7)),16)Xor_
RotateLeft(m_rbsub(RShift(x(m_ri(m+2)),24)Andm_lOnBits(7)),24)
k=k+1
Next
Fori=0Tom_Nb-1
j=i*4
UnpackFromy(i),buff,j
x(i)=0
y(i)=0
Next
EndSub
PrivateFunctionIsInitialized(vArray)
OnErrorResumeNext
IsInitialized=IsNumeric(UBound(vArray))
EndFunction
PrivateSubCopyBytesASP(bytDest,lDestStart,bytSource(),lSourceStart,lLength)
DimlCount
lCount=0
Do
bytDest(lDestStart+lCount)=bytSource(lSourceStart+lCount)
lCount=lCount+1
LoopUntillCount=lLength
EndSub
PublicFunctionEncryptData(bytMessage,bytPassword)
DimbytKey(31)
DimbytIn()
DimbytOut()
DimbytTemp(31)
DimlCount
DimlLength
DimlEncodedLength
DimbytLen(3)
DimlPosition
IfNotIsInitialized(bytMessage)Then
ExitFunction
EndIf
IfNotIsInitialized(bytPassword)Then
ExitFunction
EndIf
ForlCount=0ToUBound(bytPassword)
bytKey(lCount)=bytPassword(lCount)
IflCount=31Then
ExitFor
EndIf
Next
gentables
gkey8,8,bytKey
lLength=UBound(bytMessage)+1
lEncodedLength=lLength+4
IflEncodedLengthMod32<>0Then
lEncodedLength=lEncodedLength+32-(lEncodedLengthMod32)
EndIf
ReDimbytIn(lEncodedLength-1)
ReDimbytOut(lEncodedLength-1)
UnpacklLength,bytIn
CopyBytesASPbytIn,4,bytMessage,0,lLength
ForlCount=0TolEncodedLength-1Step32
CopyBytesASPbytTemp,0,bytIn,lCount,32
EncryptbytTemp
CopyBytesASPbytOut,lCount,bytTemp,0,32
Next
EncryptData=bytOut
EndFunction
PublicFunctionDecryptData(bytIn,bytPassword)
DimbytMessage()
DimbytKey(31)
DimbytOut()
DimbytTemp(31)
DimlCount
DimlLength
DimlEncodedLength
DimbytLen(3)
DimlPosition
IfNotIsInitialized(bytIn)Then
ExitFunction
EndIf
IfNotIsInitialized(bytPassword)Then
ExitFunction
EndIf
lEncodedLength=UBound(bytIn)+1
IflEncodedLengthMod32<>0Then
ExitFunction
EndIf
ForlCount=0ToUBound(bytPassword)
bytKey(lCount)=bytPassword(lCount)
IflCount=31Then
ExitFor
EndIf
Next
gentables
gkey8,8,bytKey
ReDimbytOut(lEncodedLength-1)
ForlCount=0TolEncodedLength-1Step32
CopyBytesASPbytTemp,0,bytIn,lCount,32
DecryptbytTemp
CopyBytesASPbytOut,lCount,bytTemp,0,32
Next
lLength=Pack(bytOut)
IflLength>lEncodedLength-4Then
ExitFunction
EndIf
ReDimbytMessage(lLength-1)
CopyBytesASPbytMessage,0,bytOut,4,lLength
DecryptData=bytMessage
EndFunction
8.一个日期转换函数
FunctionFormatDate(byValstrDate,byValstrFormat)
'AcceptsstrDateasavaliddate/time,
'strFormatastheoutputtemplate.
'Thefunctionfindseachiteminthe
'templateandreplacesitwiththe
'relevantinformationextractedfromstrDate.
'Youarefreetousethiscodeprovidedthefollowinglineremains
'www.adopenstatic.com/resources/code/formatdate.asp
'Templateitems
'%mMonthasadecimalno.2
'%MMonthasapaddeddecimalno.02
'%BFullmonthnameFebruary
'%bAbbreviatedmonthnameFeb
'%dDayofthemontheg23
'%DPaddeddayofthemontheg09
'%Oordinalofdayofmonth(egstorrdornd)
'%jDayoftheyear54
'%YYearwithcentury1998
'%yYearwithoutcentury98
'%wWeekdayasinteger(0isSunday)
'%aAbbreviateddaynameFri
'%AWeekdayNameFriday
'%HHourin24hourformat24
'%hHourin12hourformat12
'%NMinuteasaninteger01
'%nMinuteasoptionalifminute<>00
'%SSecondasaninteger55
'%PAM/PMIndicatorPM
OnErrorResumeNext
DimintPosItem
Dimint12HourPart
Dimstr24HourPart
DimstrMinutePart
DimstrSecondPart
DimstrAMPM
'InsertMonthNumbers
strFormat=Replace(strFormat,"%m",DatePart("m",strDate),1,-1,vbBinaryCompare)
'InsertPaddedMonthNumbers
strFormat=Replace(strFormat,"%M",Right("0"&DatePart("m",strDate),2),1,-1,vbBinaryCompare)
'Insertnon-AbbreviatedMonthNames
strFormat=Replace(strFormat,"%B",MonthName(DatePart("m",strDate),False),1,-1,vbBinaryCompare)
'InsertAbbreviatedMonthNames
strFormat=Replace(strFormat,"%b",MonthName(DatePart("m",strDate),True),1,-1,vbBinaryCompare)
'InsertDayOfMonth
strFormat=Replace(strFormat,"%d",DatePart("d",strDate),1,-1,vbBinaryCompare)
'InsertPaddedDayOfMonth
strFormat=Replace(strFormat,"%D",Right("0"&DatePart("d",strDate),2),1,-1,vbBinaryCompare)
'InsertDayofMonthordinal(egst,th,orrd)
strFormat=Replace(strFormat,"%O",GetDayOrdinal(Day(strDate)),1,-1,vbBinaryCompare)
'InsertDayofYear
strFormat=Replace(strFormat,"%j",DatePart("y",strDate),1,-1,vbBinaryCompare)
'InsertLongYear(4digit)
strFormat=Replace(strFormat,"%Y",DatePart("yyyy",strDate),1,-1,vbBinaryCompare)
'InsertShortYear(2digit)
strFormat=Replace(strFormat,"%y",Right(DatePart("yyyy",strDate),2),1,-1,vbBinaryCompare)
'InsertWeekdayasInteger(eg0=Sunday)
strFormat=Replace(strFormat,"%w",DatePart("w",strDate,1),1,-1,vbBinaryCompare)
'InsertAbbreviatedWeekdayName(egSun)
strFormat=Replace(strFormat,"%a",WeekdayName(DatePart("w",strDate,1),True),1,-1,vbBinaryCompare)
'Insertnon-AbbreviatedWeekdayName
strFormat=Replace(strFormat,"%A",WeekdayName(DatePart("w",strDate,1),False),1,-1,vbBinaryCompare)
'InsertHourin24hrformat
str24HourPart=DatePart("h",strDate)
IfLen(str24HourPart)<2Thenstr24HourPart="0"&str24HourPart
strFormat=Replace(strFormat,"%H",str24HourPart,1,-1,vbBinaryCompare)
'InsertHourin12hrformat
int12HourPart=DatePart("h",strDate)Mod12
Ifint12HourPart=0Thenint12HourPart=12
strFormat=Replace(strFormat,"%h",int12HourPart,1,-1,vbBinaryCompare)
'InsertMinutes
strMinutePart=DatePart("n",strDate)
IfLen(strMinutePart)<2ThenstrMinutePart="0"&strMinutePart
strFormat=Replace(strFormat,"%N",strMinutePart,1,-1,vbBinaryCompare)
'InsertOptionalMinutes
IfCInt(strMinutePart)=0Then
strFormat=Replace(strFormat,"%n","",1,-1,vbBinaryCompare)
Else
IfCInt(strMinutePart)<10ThenstrMinutePart="0"&strMinutePart
strMinutePart=":"&strMinutePart
strFormat=Replace(strFormat,"%n",strMinutePart,1,-1,vbBinaryCompare)
EndIf
'InsertSeconds
strSecondPart=DatePart("s",strDate)
IfLen(strSecondPart)<2ThenstrSecondPart="0"&strSecondPart
strFormat=Replace(strFormat,"%S",strSecondPart,1,-1,vbBinaryCompare)
'InsertAM/PMindicator
IfDatePart("h",strDate)>=12Then
strAMPM="PM"
Else
strAMPM="AM"
EndIf
strFormat=Replace(strFormat,"%P",strAMPM,1,-1,vbBinaryCompare)
FormatDate=strFormat
EndFunction
FunctionGetDayOrdinal(_
byValintDay_
)
'Acceptsadayofthemonth
'asanintegerandreturnsthe
'appropriatesuffix
OnErrorResumeNext
DimstrOrd
SelectCaseintDay
Case1,21,31
strOrd="st"
Case2,22
strOrd="nd"
Case3,23
strOrd="rd"
CaseElse
strOrd="th"
EndSelect
GetDayOrdinal=strOrd
EndFunction
%>
<%
Dimdb
db="dbms.mdb"
'******************************************************************
'执行sql语句，不返回值,sql语句最好是如下：
'update表名set字段名=value,字段名=valuewhere字段名=value
'deletefrom表名where字段名=value
'insertinto表名(字段名,字段名)values(value,value)
'******************************************************************
SubNoResult(sql)
Dimconn
Dimconnstr
Setconn=Server.CreateObject("ADODB.Connection")
connstr="Provider=Microsoft.Jet.OLEDB.4.0;DataSource="&Server.MapPath(""&db&"")
conn.Openconnstr
conn.Executesql
conn.Close
Setconn=Nothing
EndSub
'*******************************************************************
'执行select语句，返回recordset对象。该对象只读。也就是不能更新
'*******************************************************************
FunctionResult(sql)
Dimconn
Dimconnstr
Dimrcs
Setconn=Server.CreateObject("ADODB.Connection")
connstr="Provider=Microsoft.Jet.OLEDB.4.0;DataSource="&Server.MapPath(""&db&"")
conn.Openconnstr
Setrcs=Server.CreateObject("ADODB.Recordset")
rcs.Opensql,conn,1,1
SetResult=rcs
EndFunction
'*******************************************************************
'弹出对话框
'*******************************************************************
Subalert(message)
message=Replace(message,"'","'")
Response.Write("<script>alert('"&message&"')</script>")
EndSub
'*******************************************************************
'返回上一页，一般用在判断信息提交是否完全之后
'*******************************************************************
SubGoBack()
Response.Write("<script>history.go(-1)</script>")
EndSub
'*******************************************************************
'重定向另外的连接
'*******************************************************************
SubGo(url)
Response.Write("<script>location.href('"&url&"')</script>")
EndSub
'*******************************************************************
'把html标记替换
'*******************************************************************
Functionhtmlencode2(Str)
Dimresult
Diml
IfIsNull(Str)Then
htmlencode2=""
ExitFunction
EndIf
l=Len(Str)
result=""
Dimi
Fori=1Tol
SelectCaseMid(Str,i,1)
Case"<"
result=result+"<"
Case">"
result=result+">"
CaseChr(13)
result=result+"<br>"
CaseChr(34)
result=result+"""%>
<%
cLeft(String,Length)返回指定数目的从字符串的左边算起的字符，区分单双字节。
如：
DimMyString,LeftString
MyString="文字测试VBSCript"
LeftString=cLeft(MyString,10)
返回"文字测试VB"。
MyRandc(n)生成随机字符，n为字符的个数
如：
response.WriteMyRandn(10)
输出10个随机字符
MyRandn(n)生成随机数字，n为数字的个数
如：
response.WriteMyRandn(10)
输出10个随机数字
formatQueryStr(Str)格式化sql中的like字符串.
如：
q=Request("q")
q=formatQueryStr(q)
sql="select*from[table]whereaalike'%"&q&"%'"
GetRnd(min,max)返回min-max之间的一个随机数
如：
response.WriteGetRnd(100,200)
输出大于100到200之间的一个随机数
FunctioncLeft(Str,n)
Dimstr1,str2,alln,Islefted
str2=""
alln=0
str1=Str
Islefted=False
IfIsNull(Str)Then
cleft=""
ExitFunction
EndIf
Fori=1ToLen(str1)
nowstr=Mid(str1,i,1)
IfAsc(nowstr)<0Then
alln=alln+2
Else
alln=alln+1
EndIf
If(alln<=n)Then
str2=str2&nowstr
Else
Islefted=True
ExitFor
EndIf
Next
IfIsleftedThen
str2=str2&".."
EndIf
cleft=str2
EndFunction
FunctionMyRandc(n)'生成随机字符，n为字符的个数
Dimthechr
thechr=""
Fori=1Ton
DimzNum,zNum2
Randomize
zNum=CInt(25*Rnd)
zNum2=CInt(10*Rnd)
IfzNum2Mod2=0Then
zNum=zNum+97
Else
zNum=zNum+65
EndIf
thechr=thechr&Chr(zNum)
Next
MyRandc=thechr
EndFunction
FunctionMyRandn(n)'生成随机数字，n为数字的个数
Dimthechr
thechr=""
Fori=1Ton
DimzNum,zNum2
Randomize
zNum=CInt(9*Rnd)
zNum=zNum+48
thechr=thechr&Chr(zNum)
Next
MyRandn=thechr
EndFunction
FunctionformatQueryStr(Str)'格式化sql中的like字符串
Dimnstr
nstr=Str
nstr=Replace(nstr,Chr(0),"")
nstr=Replace(nstr,"'","''")
nstr=Replace(nstr,"[","[[]")
nstr=Replace(nstr,"%","[%]")
formatQueryStr=nstr
EndFunction
FunctionGetRnd(min,max)
Randomize
GetRnd=Int((max-min+1)*Rnd+min)
EndFunction
'*******************************************************************
'取得IP地址
'*******************************************************************
FunctionUserip()
DimGetClientIP
'如果客户端用了代理服务器，则应该用ServerVariables("HTTP_X_FORWARDED_FOR")方法
GetClientIP=Request.ServerVariables("HTTP_X_FORWARDED_FOR")
IfGetClientIP=""orIsNull(GetClientIP)orIsEmpty(GetClientIP)Then
'如果客户端没用代理，应该用Request.ServerVariables("REMOTE_ADDR")方法
GetClientIP=Request.ServerVariables("REMOTE_ADDR")
EndIf
Userip=GetClientIP
EndFunction
'*******************************************************************
'转换IP地址
'*******************************************************************
Functioncip(sip)
tip=CStr(sip)
sip1=Left(tip,CInt(InStr(tip,".")-1))
tip=Mid(tip,CInt(InStr(tip,".")+1))
sip2=Left(tip,CInt(InStr(tip,".")-1))
tip=Mid(tip,CInt(InStr(tip,".")+1))
sip3=Left(tip,CInt(InStr(tip,".")-1))
sip4=Mid(tip,CInt(InStr(tip,".")+1))
cip=CInt(sip1)*256*256*256+CInt(sip2)*256*256+CInt(sip3)*256+CInt(sip4)
EndFunction
'*******************************************************************
'弹出对话框
'*******************************************************************
Subalert(message)
message=Replace(message,"'","'")
Response.Write("<script>alert('"&message&"')</script>")
EndSub
'*******************************************************************
'返回上一页，一般用在判断信息提交是否完全之后
'*******************************************************************
SubGoBack()
Response.Write("<script>history.go(-1)</script>")
EndSub
'*******************************************************************
'重定向另外的连接
'*******************************************************************
SubGo(url)
Response.Write("<script>location.href('"&url&"')</script>")
EndSub
'*******************************************************************
'指定秒数重定向另外的连接
'*******************************************************************
SubGoPage(url,s)
s=s*1000
Response.Write"<SCRIPTLANGUAGE=javascript>"
Response.Write"window.setTimeout("&Chr(34)&"window.navigate('"&url&"')"&Chr(34)&","&s&")"
Response.Write"</script>"
EndSub
'*******************************************************************
'判断数字是否整形
'*******************************************************************
FunctionisInteger(para)
OnErrorResumeNext
DimStr
Diml,i
IfIsNull(para)Then
isInteger=False
ExitFunction
EndIf
Str=CStr(para)
IfTrim(Str)=""Then
isInteger=False
ExitFunction
EndIf
l=Len(Str)
Fori=1Tol
IfMid(Str,i,1)>"9"orMid(Str,i,1)<"0"Then
isInteger=False
ExitFunction
EndIf
Next
isInteger=True
IfErr.Number<>0ThenErr.Clear
EndFunction
'*******************************************************************
'获得文件扩展名
'*******************************************************************
FunctionGetExtend(filename)
Dimtmp
Iffilename<>""Then
tmp=Mid(filename,instrrev(filename,".")+1,Len(filename)-instrrev(filename,"."))
tmp=LCase(tmp)
IfInStr(1,tmp,"asp")>0orInStr(1,tmp,"php")>0orInStr(1,tmp,"php3")>0orInStr(1,tmp,"aspx")>0Then
getextend="txt"
Else
getextend=tmp
EndIf
Else
getextend=""
EndIf
EndFunction
'*----------------------------------------------------------------------------
'*函数：CheckIn
'*描述：检测参数是否有SQL危险字符
'*参数：str要检测的数据
'*返回：FALSE：安全TRUE：不安全
'*作者：
'*日期：
'*----------------------------------------------------------------------------
FunctionCheckIn(Str)
IfInStr(1,Str,Chr(39))>0orInStr(1,Str,Chr(34))>0orInStr(1,Str,Chr(59))>0Then
CheckIn=True
Else
CheckIn=False
EndIf
EndFunction
'*----------------------------------------------------------------------------
'*函数：HTMLEncode
'*描述：过滤HTML代码
'*参数：--
'*返回：--
'*作者：
'*日期：
'*----------------------------------------------------------------------------
FunctionHTMLEncode(fString)
IfNotIsNull(fString)Then
fString=Replace(fString,">",">")
fString=Replace(fString,"<","<")
fString=Replace(fString,Chr(32),"")
fString=Replace(fString,Chr(9),"")
fString=Replace(fString,Chr(34),""")
fString=Replace(fString,Chr(39),"'")
fString=Replace(fString,Chr(13),"")
fString=Replace(fString,Chr(10)&Chr(10),"</P><P>")
fString=Replace(fString,Chr(10),"<BR>")
HTMLEncode=fString
EndIf
EndFunction
'*----------------------------------------------------------------------------
'*函数：HTMLcode
'*描述：过滤表单字符
'*参数：--
'*返回：--
'*作者：
'*日期：
'*----------------------------------------------------------------------------
FunctionHTMLcode(fString)
IfNotIsNull(fString)Then
fString=Replace(fString,Chr(13),"")
fString=Replace(fString,Chr(10)&Chr(10),"</P><P>")
fString=Replace(fString,Chr(34),"")
fString=Replace(fString,Chr(10),"<BR>")
HTMLcode=fString
EndIf
EndFunction
%>
<%
cLeft(String,Length)返回指定数目的从字符串的左边算起的字符，区分单双字节。
如：
DimMyString,LeftString
MyString="文字测试VBSCript"
LeftString=cLeft(MyString,10)
返回"文字测试VB"。
MyRandc(n)生成随机字符，n为字符的个数
如：
response.WriteMyRandn(10)
输出10个随机字符
MyRandn(n)生成随机数字，n为数字的个数
如：
response.WriteMyRandn(10)
输出10个随机数字
formatQueryStr(Str)格式化sql中的like字符串.
如：
q=Request("q")
q=formatQueryStr(q)
sql="select*from[table]whereaalike'%"&q&"%'"
GetRnd(min,max)返回min-max之间的一个随机数
如：
response.WriteGetRnd(100,200)
输出大于100到200之间的一个随机数
FunctioncLeft(Str,n)
Dimstr1,str2,alln,Islefted
str2=""
alln=0
str1=Str
Islefted=False
IfIsNull(Str)Then
cleft=""
ExitFunction
EndIf
Fori=1ToLen(str1)
nowstr=Mid(str1,i,1)
IfAsc(nowstr)<0Then
alln=alln+2
Else
alln=alln+1
EndIf
If(alln<=n)Then
str2=str2&nowstr
Else
Islefted=True
ExitFor
EndIf
Next
IfIsleftedThen
str2=str2&".."
EndIf
cleft=str2
EndFunction
FunctionMyRandc(n)'生成随机字符，n为字符的个数
Dimthechr
thechr=""
Fori=1Ton
DimzNum,zNum2
Randomize
zNum=CInt(25*Rnd)
zNum2=CInt(10*Rnd)
IfzNum2Mod2=0Then
zNum=zNum+97
Else
zNum=zNum+65
EndIf
thechr=thechr&Chr(zNum)
Next
MyRandc=thechr
EndFunction
FunctionMyRandn(n)'生成随机数字，n为数字的个数
Dimthechr
thechr=""
Fori=1Ton
DimzNum,zNum2
Randomize
zNum=CInt(9*Rnd)
zNum=zNum+48
thechr=thechr&Chr(zNum)
Next
MyRandn=thechr
EndFunction
FunctionformatQueryStr(Str)'格式化sql中的like字符串
Dimnstr
nstr=Str
nstr=Replace(nstr,Chr(0),"")
nstr=Replace(nstr,"'","''")
nstr=Replace(nstr,"[","[[]")
nstr=Replace(nstr,"%","[%]")
formatQueryStr=nstr
EndFunction
FunctionGetRnd(min,max)
Randomize
GetRnd=Int((max-min+1)*Rnd+min)
EndFunction
'*******************************************************************
'取得IP地址
'*******************************************************************
FunctionUserip()
DimGetClientIP
'如果客户端用了代理服务器，则应该用ServerVariables("HTTP_X_FORWARDED_FOR")方法
GetClientIP=Request.ServerVariables("HTTP_X_FORWARDED_FOR")
IfGetClientIP=""orIsNull(GetClientIP)orIsEmpty(GetClientIP)Then
'如果客户端没用代理，应该用Request.ServerVariables("REMOTE_ADDR")方法
GetClientIP=Request.ServerVariables("REMOTE_ADDR")
EndIf
Userip=GetClientIP
EndFunction
'*******************************************************************
'转换IP地址
'*******************************************************************
Functioncip(sip)
tip=CStr(sip)
sip1=Left(tip,CInt(InStr(tip,".")-1))
tip=Mid(tip,CInt(InStr(tip,".")+1))
sip2=Left(tip,CInt(InStr(tip,".")-1))
tip=Mid(tip,CInt(InStr(tip,".")+1))
sip3=Left(tip,CInt(InStr(tip,".")-1))
sip4=Mid(tip,CInt(InStr(tip,".")+1))
cip=CInt(sip1)*256*256*256+CInt(sip2)*256*256+CInt(sip3)*256+CInt(sip4)
EndFunction
'*******************************************************************
'弹出对话框
'*******************************************************************
Subalert(message)
message=Replace(message,"'","'")
Response.Write("<script>alert('"&message&"')</script>")
EndSub
'*******************************************************************
'返回上一页，一般用在判断信息提交是否完全之后
'*******************************************************************
SubGoBack()
Response.Write("<script>history.go(-1)</script>")
EndSub
'*******************************************************************
'重定向另外的连接
'*******************************************************************
SubGo(url)
Response.Write("<script>location.href('"&url&"')</script>")
EndSub
'*******************************************************************
'指定秒数重定向另外的连接
'*******************************************************************
SubGoPage(url,s)
s=s*1000
Response.Write"<SCRIPTLANGUAGE=javascript>"
Response.Write"window.setTimeout("&Chr(34)&"window.navigate('"&url&"')"&Chr(34)&","&s&")"
Response.Write"</script>"
EndSub
'*******************************************************************
'判断数字是否整形
'*******************************************************************
FunctionisInteger(para)
OnErrorResumeNext
DimStr
Diml,i
IfIsNull(para)Then
isInteger=False
ExitFunction
EndIf
Str=CStr(para)
IfTrim(Str)=""Then
isInteger=False
ExitFunction
EndIf
l=Len(Str)
Fori=1Tol
IfMid(Str,i,1)>"9"orMid(Str,i,1)<"0"Then
isInteger=False
ExitFunction
EndIf
Next
isInteger=True
IfErr.Number<>0ThenErr.Clear
EndFunction
'*******************************************************************
'获得文件扩展名
'*******************************************************************
FunctionGetExtend(filename)
Dimtmp
Iffilename<>""Then
tmp=Mid(filename,instrrev(filename,".")+1,Len(filename)-instrrev(filename,"."))
tmp=LCase(tmp)
IfInStr(1,tmp,"asp")>0orInStr(1,tmp,"php")>0orInStr(1,tmp,"php3")>0orInStr(1,tmp,"aspx")>0Then
getextend="txt"
Else
getextend=tmp
EndIf
Else
getextend=""
EndIf
EndFunction
'*----------------------------------------------------------------------------
'*函数：CheckIn
'*描述：检测参数是否有SQL危险字符
'*参数：str要检测的数据
'*返回：FALSE：安全TRUE：不安全
'*作者：
'*日期：
'*----------------------------------------------------------------------------
FunctionCheckIn(Str)
IfInStr(1,Str,Chr(39))>0orInStr(1,Str,Chr(34))>0orInStr(1,Str,Chr(59))>0Then
CheckIn=True
Else
CheckIn=False
EndIf
EndFunction
'*----------------------------------------------------------------------------
'*函数：HTMLEncode
'*描述：过滤HTML代码
'*参数：--
'*返回：--
'*作者：
'*日期：
'*----------------------------------------------------------------------------
FunctionHTMLEncode(fString)
IfNotIsNull(fString)Then
fString=Replace(fString,">",">")
fString=Replace(fString,"<","<")
fString=Replace(fString,Chr(32),"")
fString=Replace(fString,Chr(9),"")
fString=Replace(fString,Chr(34),""")
fString=Replace(fString,Chr(39),"'")
fString=Replace(fString,Chr(13),"")
fString=Replace(fString,Chr(10)&Chr(10),"</P><P>")
fString=Replace(fString,Chr(10),"<BR>")
HTMLEncode=fString
EndIf
EndFunction
'*----------------------------------------------------------------------------
'*函数：HTMLcode
'*描述：过滤表单字符
'*参数：--
'*返回：--
'*作者：
'*日期：
'*----------------------------------------------------------------------------
FunctionHTMLcode(fString)
IfNotIsNull(fString)Then
fString=Replace(fString,Chr(13),"")
fString=Replace(fString,Chr(10)&Chr(10),"</P><P>")
fString=Replace(fString,Chr(34),"")
fString=Replace(fString,Chr(10),"<BR>")
HTMLcode=fString
EndIf
EndFunction
%>
11.ACCESS数据库连接:
<%
OptionExplicit
Dimstartime,endtime,conn,connstr,db
startime=Timer()
'更改数据库名字
db="data/dvBBS5.mdb"
Setconn=Server.CreateObject("ADODB.Connection")
connstr="Provider=Microsoft.Jet.OLEDB.4.0;DataSource="&Server.MapPath(db)
'如果你的服务器采用较老版本Access驱动，请用下面连接方法
'connstr="driver={MicrosoftAccessDriver(*.mdb)};dbq="&Server.MapPath(db)
conn.Openconnstr
FunctionCloseDatabase
Conn.Close
Setconn=Nothing
EndFunction
%>
12.SQL数据库连接:
<%
OptionExplicit
Dimstartime,endtime,conn,connstr,db
startime=Timer()
connstr="driver={SQLServer};server=HUDENQ-N11T33NB;uid=sa;pwd=xsfeihu;database=dvbbs"
Setconn=Server.CreateObject("ADODB.Connection")
conn.Openconnstr
FunctionCloseDatabase
Conn.Close
Setconn=Nothing
EndFunction
%>
13.用键盘打开网页代码:
<scriptlanguage="javascript">
functionctlent(eventobject)
{
if((event.ctrlKey&&window.event.keyCode==13)||(event.altKey&&window.event.keyCode==83))
{
window.open('网址','','')
}
}
</script>
这里是Ctrl+Enter和Alt+S的代码自己查下键盘的ASCII码再换就行
14.让层不被控件复盖代码:
<divz-Index:2><object***></object></div>＃前面
<divz-Index:1><object***></object></div>＃后面
<divid="Layer2"><tableheight=100%width=100%bgcolor="#ff0000"><tr><tdheight=100%width=100%></td></tr></table><iframewidth=0height=0></iframe></div>
<divid="Layer1"><iframeheight=100%width=100%></iframe></div>
15.动网FLASH广告代码:
<objectclassid="clsid27CDB6E-AE6D-11cf-96B8-444553540000"codebase="http://download.macromedia.com/pub/shockwave/cabs/flash/swflash.cab#version=5,0,0,0"width="468"height="60"><paramname=movievalue="images/yj16d.swf"><paramname=qualityvalue=high><embedsrc="images/dvbanner.swf"quality=highpluginspage="http://www.macromedia.com/shockwave/download/index.cgi?P1_Prod_Version=ShockwaveFlash";;;type="application/x-shockwave-flash"width="468"height="60"></embed></object>
16.VBS弹出窗口小代码:
<scriptlanguage=vbscript>
msgbox"你还没有注册或登陆论坛","0","精品论坛"
location.href="login.asp"
</script>
16.使用FSO修改文件特定内容的函数
<%
FunctionFSOchange(filename,Target,String)
DimobjFSO,objCountFile,FiletempData
SetobjFSO=Server.CreateObject("Scripting.FileSystemObject")
SetobjCountFile=objFSO.OpenTextFile(Server.MapPath(filename),1,True)
FiletempData=objCountFile.ReadAll
objCountFile.Close
FiletempData=Replace(FiletempData,Target,String)
SetobjCountFile=objFSO.CreateTextFile(Server.MapPath(filename),True)
objCountFile.WriteFiletempData
objCountFile.Close
SetobjCountFile=Nothing
SetobjFSO=Nothing
EndFunction
%>
17.使用FSO读取文件内容的函数
<%
FunctionFSOFileRead(filename)
DimobjFSO,objCountFile,FiletempData
SetobjFSO=Server.CreateObject("Scripting.FileSystemObject")
SetobjCountFile=objFSO.OpenTextFile(Server.MapPath(filename),1,True)
FSOFileRead=objCountFile.ReadAll
objCountFile.Close
SetobjCountFile=Nothing
SetobjFSO=Nothing
EndFunction
%>
18.使用FSO读取文件某一行的函数
<%
FunctionFSOlinedit(filename,lineNum)
Iflinenum<1ThenExitFunction
Dimfso,f,temparray,tempcnt
Setfso=server.CreateObject("scripting.filesystemobject")
IfNotfso.FileExists(server.mappath(filename))ThenExitFunction
Setf=fso.OpenTextFile(server.mappath(filename),1)
IfNotf.AtEndOfStreamThen
tempcnt=f.ReadAll
f.Close
Setf=Nothing
temparray=Split(tempcnt,Chr(13)&Chr(10))
IflineNum>UBound(temparray)+1Then
ExitFunction
Else
FSOlinedit=temparray(lineNum-1)
EndIf
EndIf
EndFunction
%>
19.使用FSO写文件某一行的函数
<%
FunctionFSOlinewrite(filename,lineNum,Linecontent)
Iflinenum<1ThenExitFunction
Dimfso,f,temparray,tempCnt
Setfso=server.CreateObject("scripting.filesystemobject")
IfNotfso.FileExists(server.mappath(filename))ThenExitFunction
Setf=fso.OpenTextFile(server.mappath(filename),1)
IfNotf.AtEndOfStreamThen
tempcnt=f.ReadAll
f.Close
temparray=Split(tempcnt,Chr(13)&Chr(10))
IflineNum>UBound(temparray)+1Then
ExitFunction
Else
temparray(lineNum-1)=lineContent
EndIf
tempcnt=Join(temparray,Chr(13)&Chr(10))
Setf=fso.CreateTextFile(server.mappath(filename),True)
f.Writetempcnt
EndIf
f.Close
Setf=Nothing
EndFunction
%>
20.使用FSO添加文件新行的函数
<%
FunctionFSOappline(filename,Linecontent)
Dimfso,f
Setfso=server.CreateObject("scripting.filesystemobject")
IfNotfso.FileExists(server.mappath(filename))ThenExitFunction
Setf=fso.OpenTextFile(server.mappath(filename),8,1)
f.WriteChr(13)&Chr(10)&Linecontent
f.Close
Setf=Nothing
EndFunction
%>
21.读文件最后一行的函数
<%
FunctionFSOlastline(filename)
Dimfso,f,temparray,tempcnt
Setfso=server.CreateObject("scripting.filesystemobject")
IfNotfso.FileExists(server.mappath(filename))ThenExitFunction
Setf=fso.OpenTextFile(server.mappath(filename),1)
IfNotf.AtEndOfStreamThen
tempcnt=f.ReadAll
f.Close
Setf=Nothing
temparray=Split(tempcnt,Chr(13)&Chr(10))
FSOlastline=temparray(UBound(temparray))
EndIf
EndFunction
%>
利用FSO取得BMP，JPG，PNG，GIF文件信息(大小，宽、高等)
<%
':::BMP,GIF,JPGandPNG:::
':::Thisfunctiongetsaspecifiednumberofbytesfromany:::
':::file,startingattheoffset(base1):::
'::::::
':::Passed::::
':::flnm=>Filespecoffiletoread:::
':::offset=>Offsetatwhichtostartreading:::
':::bytes=>Howmanybytestoread:::
'::::::
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
FunctionGetBytes(flnm,offset,bytes)
DimobjFSO
DimobjFTemp
DimobjTextStream
DimlngSize
OnErrorResumeNext
SetobjFSO=CreateObject("Scripting.FileSystemObject")
'First,wegetthefilesize
SetobjFTemp=objFSO.GetFile(flnm)
lngSize=objFTemp.Size
SetobjFTemp=Nothing
fsoForReading=1
SetobjTextStream=objFSO.OpenTextFile(flnm,fsoForReading)
Ifoffset>0Then
strBuff=objTextStream.Read(offset-1)
EndIf
Ifbytes=-1Then'GetAll!
GetBytes=objTextStream.Read(lngSize)'ReadAll
Else
GetBytes=objTextStream.Read(bytes)
EndIf
objTextStream.Close
SetobjTextStream=Nothing
SetobjFSO=Nothing
EndFunction
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
'::::::
':::Functionstoconverttwobytestoanumericvalue(long):::
':::(bothlittle-endianandbig-endian):::
'::::::
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
FunctionlngConvert(strTemp)
lngConvert=CLng(Asc(Left(strTemp,1))+((Asc(Right(strTemp,1))*256)))
EndFunction
FunctionlngConvert2(strTemp)
lngConvert2=CLng(Asc(Right(strTemp,1))+((Asc(Left(strTemp,1))*256)))
EndFunction
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
'::::::
':::Thisfunctiondoesmostoftherealwork.Itwillattempt:::
':::toreadanyfile,regardlessoftheextension,andwill:::
':::identifyifitisagraphicalimage.:::
'::::::
':::Passed::::
':::flnm=>Filespecoffiletoread:::
':::width=>widthofimage:::
':::height=>heightofimage:::
':::depth=>colordepth(innumberofcolors):::
':::strImageType=>typeofimage(e.g.GIF,BMP,etc.):::
'::::::
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
FunctiongfxSpex(flnm,Width,height,depth,strImageType)
DimstrPNG
DimstrGIF
DimstrBMP
DimstrType
strType=""
strImageType="(unknown)"
gfxSpex=False
strPNG=Chr(137)&Chr(80)&Chr(78)
strGIF="GIF"
strBMP=Chr(66)&Chr(77)
strType=GetBytes(flnm,0,3)
IfstrType=strGIFThen'isGIF
strImageType="GIF"
Width=lngConvert(GetBytes(flnm,7,2))
Height=lngConvert(GetBytes(flnm,9,2))
Depth=2^((Asc(GetBytes(flnm,11,1))And7)+1)
gfxSpex=True
ElseIfLeft(strType,2)=strBMPThen'isBMP
strImageType="BMP"
Width=lngConvert(GetBytes(flnm,19,2))
Height=lngConvert(GetBytes(flnm,23,2))
Depth=2^(Asc(GetBytes(flnm,29,1)))
gfxSpex=True
ElseIfstrType=strPNGThen'IsPNG
strImageType="PNG"
Width=lngConvert2(GetBytes(flnm,19,2))
Height=lngConvert2(GetBytes(flnm,23,2))
Depth=getBytes(flnm,25,2)
SelectCaseAsc(Right(Depth,1))
Case0
Depth=2^(Asc(Left(Depth,1)))
gfxSpex=True
Case2
Depth=2^(Asc(Left(Depth,1))*3)
gfxSpex=True
Case3
Depth=2^(Asc(Left(Depth,1)))'8
gfxSpex=True
Case4
Depth=2^(Asc(Left(Depth,1))*2)
gfxSpex=True
Case6
Depth=2^(Asc(Left(Depth,1))*4)
gfxSpex=True
CaseElse
Depth=-1
EndSelect
Else
strBuff=GetBytes(flnm,0,-1)'Getallbytesfromfile
lngSize=Len(strBuff)
flgFound=0
strTarget=Chr(255)&Chr(216)&Chr(255)
flgFound=InStr(strBuff,strTarget)
IfflgFound=0Then
ExitFunction
EndIf
strImageType="JPG"
lngPos=flgFound+2
ExitLoop=False
DoWhileExitLoop=FalseAndlngPos<lngSize
DoWhileAsc(Mid(strBuff,lngPos,1))=255AndlngPos<lngSize
lngPos=lngPos+1
Loop
IfAsc(Mid(strBuff,lngPos,1))<192orAsc(Mid(strBuff,lngPos,1))>195Then
lngMarkerSize=lngConvert2(Mid(strBuff,lngPos+1,2))
lngPos=lngPos+lngMarkerSize+1
Else
ExitLoop=True
EndIf
Loop
'
IfExitLoop=FalseThen
Width=-1
Height=-1
Depth=-1
Else
Height=lngConvert2(Mid(strBuff,lngPos+4,2))
Width=lngConvert2(Mid(strBuff,lngPos+6,2))
Depth=2^(Asc(Mid(strBuff,lngPos+8,1))*8)
gfxSpex=True
EndIf
EndIf
EndFunction
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
':::TestHarness:::
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
'Totest,we'lljusttrytoshowallfileswitha.GIFextensionintherootofC:
SetobjFSO=CreateObject("Scripting.FileSystemObject")
SetobjF=objFSO.GetFolder("c:")
SetobjFC=objF.Files
response.Write"<tableborder=""0""cellpadding=""5"">"
ForEachf1inobjFC
IfInStr(UCase(f1.Name),".GIF")Then
response.Write"<tr><td>"&f1.Name&"</td><td>"&f1.DateCreated&"</td><td>"&f1.Size&"</td><td>"
IfgfxSpex(f1.Path,w,h,c,strType)=TrueThen
response.Writew&"x"&h&""&c&"colors"
Else
response.Write""
EndIf
response.Write"</td></tr>"
EndIf
Next
response.Write"</table>"
SetobjFC=Nothing
SetobjF=Nothing
SetobjFSO=Nothing
%>
24.点击返回上页代码:
<form>
<p><inputTYPE="button"value="返回上一步"onCLICK="history.back(-1)"></p>
</form>
24.点击刷新代码:
<form>
<p><inputTYPE="button"value="刷新按钮一"onCLICK="ReloadButton()"></p>
</form>
<scriptlanguage="javascript"><></script>
24.点击刷新代码2:
<form>
<p><inputTYPE="button"value="刷新按钮二"onClick="history.go(0)"></p>
</form>
<form>
<p><inputTYPE="button"value="打开一个网站"onCLICK="HomeButton()"></p>
</form>
<scriptlanguage="javascript"><></script>
25.弹出警告框代码:
<form>
<p><inputTYPE="button"value="弹出警告框"onCLICK="AlertButton()"></p>
</form>
<scriptlanguage="javascript"><></script>
26.状态栏信息
<form>
<p><inputTYPE="button"value="状态栏信息"onCLICK="StatusButton()"></p>
</form>
<scriptlanguage="javascript"><></script>
27.背景色变换
<form>
<p><inputTYPE="button"value="背景色变换"onClick="BgButton()"></p>
</form>
<script>functionBgButton(){
if(document.bgColor=='#00ffff')
{document.bgColor='#ffffff';}
else{document.bgColor='#00ffff';}
}
</script>
28.点击打开新窗口
<form>
<p><inputTYPE="button"value="打开新窗口"onCLICK="NewWindow()"></p>
</form>
<scriptlanguage="javascript"><></script></body>
29.分页代码:
<%''本程序文件名为：Pages.asp%>
<%''包含ADO常量表文件adovbs.inc，可从"ProgramFilesCommonFilesSystemADO"目录下拷贝%>
<>
<%''＊建立数据库连接，这里是Oracle8.05数据库
Setconn=Server.CreateObject("ADODB.Connection")
conn.Open"Provider=msdaora.1;DataSource=YourSrcName;UserID=YourUserID;Password=YourPassword;"
Setrs=Server.CreateObject("ADODB.Recordset")''创建Recordset对象
rs.CursorLocation=adUseClient''设定记录集指针属性
''＊设定一页内的记录总数，可根据需要进行调整
rs.PageSize=10
''＊设置查询语句
StrSQL="SelectID,姓名,住址,电话from通讯录orderByID"
rs.OpenStrSQL,conn,adOpenStatic,adLockReadOnly,adCmdText
%>
<HTML>
<HEAD>
<title>分页示例</title>
<scriptlanguage=javascript>
//点击"[第一页]"时响应：
functionPageFirst()
{
document.MyForm.CurrentPage.selectedIndex=0;
document.MyForm.CurrentPage.onchange();
}
//点击"[上一页]"时响应：
functionPagePrior()
{
document.MyForm.CurrentPage.selectedIndex--;
document.MyForm.CurrentPage.onchange();
}
//点击"[下一页]"时响应：
functionPageNext()
{
document.MyForm.CurrentPage.selectedIndex++;
document.MyForm.CurrentPage.onchange();
}
//点击"[最后一页]"时响应：
functionPageLast()
{
document.MyForm.CurrentPage.selectedIndex=document.MyForm.CurrentPage.length-1;
document.MyForm.CurrentPage.onchange();
}
//选择"第？页"时响应：
functionPageCurrent()
{//Pages.asp是本程序的文件名
document.MyForm.action='Pages.asp?Page='+(document.MyForm.CurrentPage.selectedIndex+1)
document.MyForm.submit();
}
</Script>
</HEAD>
<BODYbgcolor="#ffffcc"link="#008000"vlink="#008000"alink="#FF0000"">
<%
Ifrs.EOFThen
Response.Write("<fontsize=2color=#000080>[数据库中没有记录！]</font>")
Else
''指定当前页码
IfRequest("CurrentPage")=""Then
rs.AbsolutePage=1
Else
rs.AbsolutePage=CLng(Request("CurrentPage"))
EndIf
''创建表单MyForm,方法为Get
Response.Write("<formmethod=Getname=MyForm>")
Response.Write("<palign=center><fontsize=2color=#008000>")
''设置翻页超链接
Ifrs.PageCount=1Then
Response.Write("[第一页][上一页][下一页][最后一页]")
Else
Ifrs.AbsolutePage=1Then
Response.Write("[第一页][上一页]")
Response.Write("[<ahref=javascript:PageNext()>下一页</a>]")
Response.Write("[<ahref=javascript:PageLast()>最后一页</a>]")
Else
Ifrs.AbsolutePage=rs.PageCountThen
Response.Write("[<ahref=javascript:PageFirst()>第一页</a>]")
Response.Write("[<ahref=javascript:PagePrior()>上一页</a>]")
Response.Write("[下一页][最后一页]")
Else
Response.Write("[<ahref=javascript:PageFirst()>第一页</a>]")
Response.Write("[<ahref=javascript:PagePrior()>上一页</a>]")
Response.Write("[<ahref=javascript:PageNext()>下一页</a>]")
Response.Write("[<ahref=javascript:PageLast()>最后一页</a>]")
EndIf
EndIf
EndIf
''创建下拉列表框，用于选择浏览页码
Response.Write("第<selectsize=1name=CurrentPageonchange=PageCurrent()>")
Fori=1Tors.PageCount
Ifrs.AbsolutePage=iThen
Response.Write("<optionselected>"&i&"</option>")''当前页码
Else
Response.Write("<option>"&i&"</option>")
EndIf
Next
Response.Write("</select>页/共"&rs.PageCount&"页共"&rs.RecordCount&"条记录</font><p>")
Response.Write("</form>")
''创建表格，用于显示
Response.Write("<tablealign=centercellspacing=1cellpadding=1border=1")
Response.Write("bordercolor=#99CCFFbordercolordark=#b0e0e6bordercolorlight=#000066>")
Response.Write("<trbgcolor=#ccccffbordercolor=#000066>")
SetColumns=rs.Fields
''显示表头
Fori=0ToColumns.Count-1
Response.Write("<tdalign=centerwidth=200height=13>")
Response.Write("<fontsize=2><b>"&Columns(i).Name&"</b></font></td>")
Next
Response.Write("</tr>")
''显示内容
Fori=1Tors.PageSize
Response.Write("<trbgcolor=#99ccffbordercolor=#000066>")
Forj=0ToColumns.Count-1
Response.Write("<td><fontsize=2>"&Columns(j)&"</font></td>")
Next
Response.Write("</tr>")
rs.movenext
Ifrs.EOFThenExitFor
Next
Response.Write("</table>")
EndIf
%>
</BODY>
</HTML>
<%
Rem---表单提示函数Being-----------------------------
CODECopy...
FunctionCheck_submit(Str,restr)
IfStr=""Then
response.Write"<script>"
response.Write"alert(‘'"&restr&"‘');"
response.Write"history.go(-1)"
response.Write"</script>"
response.End
Else
Check_submit=Str
EndIf
EndFunction
CODECopy...
FunctionAlert_submit(Str)
response.Write"<script>"
response.Write"alert(‘'"&Str&"‘');"
‘'response.Write"location.reload();"
response.Write"</script>"
EndFunction
CODECopy...
Functionlocalhost_submit(Str,urls)
response.Write"<script>"
IfStr<>""Then
response.Write"alert(‘'"&Str&"‘');"
EndIf
response.Write"location=‘'"&urls&"‘';"
response.Write"</script>"
EndFunction
Rem---生成自定义位随机数Being-----------------------------
CODECopy...
Functionmakerndid(byValmaxLen)
DimstrNewPass
DimwhatsNext,upper,lower,intCounter
Randomize
ForintCounter=1TomaxLen
whatsNext=Int(2*Rnd)
IfwhatsNext=0Then
upper=80
lower=70
Else
upper=48
lower=39
EndIf
strNewPass=strNewPass&Chr(Int((upper-lower+1)*Rnd+upper))
Next
makerndid=strNewPass
EndFunction
Rem---生成四位随机数Being-----------------------------
CODECopy...
Functionget_rand()
Dimnum1
Dimrndnum
Randomize
DoWhileLen(rndnum)<4
num1=CStr(Chr((57-48)*Rnd+48))
rndnum=rndnum&num1
Loop
get_rand=rndnum
EndFunction
Rem---判断数据是否整型Being-----------------------------
CODECopy...
FunctionIsInteger(para)
OnErrorResumeNext
DimStr
Diml,i
IfIsNull(para)Then
isInteger=False
ExitFunction
EndIf
Str=CStr(para)
IfTrim(Str)=""Then
isInteger=False
ExitFunction
EndIf
l=Len(Str)
Fori=1Tol
IfMid(Str,i,1)>"9"orMid(Str,i,1)<"0"Then
isInteger=False
ExitFunction
EndIf
Next
isInteger=True
IfErr.Number<>0ThenErr.Clear
EndFunction
Rem---数据库链接函数Being-----------------------------
CODECopy...
FunctionOpenCONN
Setconn=Server.CreateObject("ADODB.Connection")
connstr="Provider=Microsoft.Jet.OLEDB.4.0;DataSource="&Server.MapPath(DB_login)
conn.Openconnstr
EndFunction
Rem---中文字符转Uncode代码函数Being-----------------------------
CODECopy...
FunctionURLEncoding(vstrIn)
strReturn=""
Fori=1ToLen(vstrIn)
ThisChr=Mid(vStrIn,i,1)
IfAbs(Asc(ThisChr))<&HFFThen
strReturn=strReturn&ThisChr
Else
innerCode=Asc(ThisChr)
IfinnerCode<0Then
innerCode=innerCode+&H10000
EndIf
Hight8=(innerCodeAnd&HFF00)&HFF
Low8=innerCodeAnd&HFF
strReturn=strReturn&"%"&Hex(Hight8)&"%"&Hex(Low8)
EndIf
Next
URLEncoding=strReturn
EndFunction
Rem---Html过滤函数Being-----------------------------FunctionHtmlout(Str)
CODECopy...
Dimresult
Diml
IfIsNull(Str)Then
Htmlout=""
ExitFunction
EndIf
l=Len(Str)
result=""
Dimi
Fori=1Tol
SelectCaseMid(Str,i,1)
Case"<"
result=result+"<"
Case">"
result=result+">"
CaseChr(13)
Ifsession("admin_system")=""Then
result=result+"<br>"
EndIf
CaseChr(34)
result=result+"""
Case"&"
result=result+"&"
CaseChr(32)
‘'result=result+""
Ifi+1<=lAndi-1>0Then
IfMid(Str,i+1,1)=Chr(32)orMid(Str,i+1,1)=Chr(9)orMid(Str,i-1,1)=Chr(32)orMid(Str,i-1,1)=Chr(9)Then
result=result+""
Else
result=result+""
EndIf
Else
result=result+""
EndIf
CaseChr(9)
result=result+""
CaseElse
result=result+Mid(Str,i,1)
EndSelect
Next
Htmlout=result
EndFunction
Rem---textarea显示用---
CODECopy...
Functionhtmlencode1(fString)
IffString<>""AndNotIsNull(fString)Then
fString=Replace(fString,">",">")
fString=Replace(fString,"<","<")
fString=Replace(fString,"",Chr(32))
fString=Replace(fString,"</p><p>",Chr(10)&Chr(10))
fString=Replace(fString,"<br>",Chr(10))
htmlencode1=fString
Else
htmlencode1=""
EndIf
EndFunction
Rem---页面显示用---
CODECopy...
Functionhtmlencode2(fString)
IffString<>""AndNotIsNull(fString)Then
fString=Replace(fString,">",">")
fString=Replace(fString,"<","<")
fString=Replace(fString,Chr(32),"")
fString=Replace(fString,Chr(10)&Chr(10),"</p><p>")
fString=Replace(fString,Chr(10),"<br>")
htmlencode2=fString
Else
htmlencode2=""
EndIf
EndFunction
Rem---取出指定字符串前后的字符串方法---
CODECopy...
FunctionGetStrs(str1,CharFlag,Dflag)
Dimtmpstr
IfDflag=0Then‘'取左
pos1=InStr(str1,charFlag)
Ifpos1<=20Then
tmpstr=Left(str1,pos1-1)
Else
tmpstr=Mid(str1,pos1-20,20)
EndIf
Else‘'取右
pos1=InStr(str1,charFlag)+Len(charFlag)
IfLen(str1)-pos1<=20Then
tmpstr=Right(str1,Len(str1)-pos1)
Else
tmpstr=Mid(str1,pos1+1,20)
EndIf
EndIf
GetStrs=tmpstr
EndFunction
Rem---取出文件名---
CODECopy...
FunctionGetFileName(Str)
pos=InStr(Str,".")
IfStr<>""Then
Str=Mid(Str,pos,Len(Str))
EndIf
GetFileName=Str
EndFunction
Rem---取到浏览器版本转换字符串---
CODECopy...
Functionbrowser()
Dimtext
text=Request.ServerVariables("HTTP_USER_AGENT")
IfInStr(text,"MSIE5.5")>0Then
browser="IE5.5"
ElseIfInStr(text,"MSIE6.0")>0Then
browser="IE6.0"
ElseIfInStr(text,"MSIE5.01")>0Then
browser="IE5.01"
ElseIfInStr(text,"MSIE5.0")>0Then
browser="IE5.00"
ElseIfInStr(text,"MSIE4.0")>0Then
browser="IE4.01"
Else
browser="未知"
EndIf
EndFunction
Rem---取到系统脚本转换字符串---
CODECopy...
FunctionSystem(text)
IfInStr(text,"NT5.1")>0Then
System=System+"WindowsXP"
ElseIfInStr(text,"NT5")>0Then
System=System+"Windows2000"
ElseIfInStr(text,"NT4")>0Then
System=System+"WindowsNT4"
ElseIfInStr(text,"4.9")>0Then
System=System+"WindowsME"
ElseIfInStr(text,"98")>0Then
System=System+"Windows98"
ElseIfInStr(text,"95")>0Then
System=System+"Windows95"
Else
System=System+"未知"
EndIf
EndFunction
Rem---=删除文件---
CODECopy...
Functiondelfile(filepath)
imangepath=Trim(filepath)
Path=server.MapPath(imangepath)
Setfs=server.CreateObject("Scripting.FileSystemObject")
IfFS.FileExists(Path)Then
FS.DeleteFile(Path)
EndIf
Setfs=Nothing
EndFunction
Rem---得到真实的客户端IP---
CODECopy...
PublicFunctionGetClientIP()
DimuIpAddr
‘'本函数参考webcn.Net/AspHouse文献<取真实的客户IP>
uIpAddr=Request.ServerVariables("HTTP_X_FORWARDED_FOR")
IfuIpAddr=""ThenuIpAddr=Request.ServerVariables("REMOTE_ADDR")
GetClientIP=uIpAddr
uIpAddr=""
EndFunction
%>
数据库查询中的特殊字符的问题
在进行数据库的查询时，会经常遇到这样的情况：
例如想在一个用户数据库中查询他的用户名和他的密码，但恰好该用户使用的名字和密码中有特殊的字符，例如单引号，“|”号，双引号或者连字符“&”。
例如他的名字是1"test，密码是A|&900
这时当你执行以下的查询语句时，肯定会报错：
SQL="Select*FROMSecurityLevelWhereUID=""&UserID&"""
SQL=SQL&"ANDPWD=""&Password&"""
因为你的SQL将会是这样：
Select*FROMSecurityLevelWhereUID="1"test"ANDPWD="A|&900"
在SQL中，"|"为分割字段用的，显然会出错了。现在提供下面的几个函数专门用来处理这些头疼的东西：
QuotedfromUnkown:
<%
FunctionReplaceStr(TextIn,ByValSearchStrAsString,_
ByValReplacementAsString,_
ByValCompModeAsInteger)
DimWorkTextAsString,PointerAsInteger
IfIsNull(TextIn)Then
ReplaceStr=Null
Else
WorkText=TextIn
Pointer=InStr(1,WorkText,SearchStr,CompMode)
DoWhilePointer>0
WorkText=Left(WorkText,Pointer-1)&Replacement&_
Mid(WorkText,Pointer+Len(SearchStr))
Pointer=InStr(Pointer+Len(Replacement),WorkText,SearchStr,CompMode)
Loop
ReplaceStr=WorkText
EndIf
EndFunction
FunctionSQLFixup(TextIn)
SQLFixup=ReplaceStr(TextIn,""","""",0)
EndFunction
FunctionJetSQLFixup(TextIn)
DimTemp
Temp=ReplaceStr(TextIn,""","""",0)
JetSQLFixup=ReplaceStr(Temp,"|",""&Chr(124)&"",0)
EndFunction
FunctionFindFirstFixup(TextIn)
DimTemp
Temp=ReplaceStr(TextIn,""",""&chr(39)&"",0)
FindFirstFixup=ReplaceStr(Temp,"|",""&Chr(124)&"",0)
EndFunction
Rem借助RecordSet将二进制流转化成文本
QuotedfromUnkown:
FunctionBinaryToString(biData,Size)
ConstadLongVarChar=201
SetRS=CreateObject("ADODB.Recordset")
RS.Fields.Append"mBinary",adLongVarChar,Size
RS.Open
RS.AddNew
RS("mBinary").AppendChunk(biData)
RS.Update
BinaryToString=RS("mBinary").Value
RS.Close
EndFunction
%>
<%
'定义超全局变量
DimURLSelf,URISelf
URISelf=Request.ServerVariables("SCRIPT_NAME")
IfRequest.QueryString=""Then
URLSelf=URISelf
Else
URLSelf=URISelf&"?"&Request.QueryString
EndIf
Response.CharSet="GB2312"
Response.Buffer=True
Response.Expires=-1
'===================================================================================
'函数原型：GotoURL(URL)
'功能：转到指定的URL
'参数：URL要跳转的URL
'返回值：无
'涉及的表：无
'===================================================================================
PublicFunctionGotoURL(URL)
Response.Write"<scriptlanguage=""JavaScript"">location.href='"&URL&"';</script>"
EndFunction
'===================================================================================
'函数原型：MessageBox(Msg)
'功能：显示消息框
'参数：要显示的消息
'返回值：无
'涉及的表：无
'===================================================================================
PublicFunctionMessageBox(msg)
msg=Replace(msg,"","")
msg=Replace(msg,"'","'")
msg=Replace(msg,"""","""")
msg=Replace(msg,vbCrLf,"n")
msg=Replace(msg,vbCr,"")
msg=Replace(msg,vbLf,"")
Response.Write"<scriptlanguage=""JavaScript"">alert('"&msg&"');</script>"
EndFunction
'===================================================================================
'函数原型：ReturnValue(bolValue)
'功能：设置Window对象的返回值：只能是布尔值
'参数：返回值
'返回值：无
'涉及的表：无
'===================================================================================
PublicFunctionReturnValue(bolValue)
IfbolValueThen
Response.Write"<scriptlanguage=""JavaScript"">window.returnValue=true;</script>"
Else
Response.Write"<scriptlanguage=""JavaScript"">window.returnValue=false;</script>"
EndIf
EndFunction
'===================================================================================
'函数原型：GoBack(URL)
'功能：后退
'参数：无
'返回值：无
'涉及的表：无
'===================================================================================
PublicFunctionGoBack()
Response.Write"<scriptlanguage=""JavaScript"">history.go(-1);</script>"
EndFunction
'===================================================================================
'函数原型：CloseWindow()
'功能：关闭窗口
'参数：无
'返回值：无
'涉及的表：无
'===================================================================================
PublicFunctionCloseWindow()
Response.Write"<scriptlanguage=""JavaScript"">window.opener=null;window.close();</script>"
EndFunction
'===================================================================================
'函数原型：RefreshParent()
'功能：刷新父框架
'参数：无
'返回值：无
'涉及的表：无
'===================================================================================
PublicFunctionRefreshParent()
Response.Write"<scriptlanguage=""JavaScript"">if(parent!=self)parent.location.reload();</script>"
EndFunction
'===================================================================================
'函数原型：RefreshTop()
'功能：刷新顶级框架
'参数：无
'返回值：无
'涉及的表：无
'===================================================================================
PublicFunctionRefreshTop()
Response.Write"<scriptlanguage=""JavaScript"">if(top!=self)top.location.reload();</script>"
EndFunction
'===================================================================================
'函数原型：GenPassword(intLen,PassMask)
'功能：生成随机密码
'参数：intLen新密码长度
'PassMask生成密码的掩码默认为空
'返回值：无
'涉及的表：无
'===================================================================================
PublicFunctionGenPassword(intLen,PassMask)
DimiCnt,PosTemp
Randomize
IfPassMask=""Then
PassMask="ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789abcdefghijklmnopqrstuvwxyz"
EndIf
ForiCnt=1TointLen
PosTemp=Fix(Rnd(1)*(Len(PassMask)))+1
GenPassword=GenPassword&Mid(PassMask,PosTemp,1)
Next
EndFunction
'===================================================================================
'函数原型：GenSerialString()
'功能：生成序列号
'参数：无
'返回值：无
'涉及的表：无
'===================================================================================
PublicFunctionGenSerialString()
GenSerialString=Year(Now())
IfMonth(Now())<10Then
GenSerialString=GenSerialString&"0"
EndIf
GenSerialString=GenSerialString&Month(Now())
IfDay(Now())<10Then
GenSerialString=GenSerialString&"0"
EndIf
GenSerialString=GenSerialString&Day(Now())
IfHour(Now())<10Then
GenSerialString=GenSerialString&"0"
EndIf
GenSerialString=GenSerialString&Hour(Now())
IfMinute(Now())<10Then
GenSerialString=GenSerialString&"0"
EndIf
GenSerialString=GenSerialString&Minute(Now())
IfSecond(Now())<10Then
GenSerialString=GenSerialString&"0"
EndIf
GenSerialString=GenSerialString&Second(Now())
GenSerialString=GenSerialString&GenPassword(6,"0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ")
EndFunction
'===================================================================================
'函数原型：ChangePage(URLTemplete,PageIndex)
'功能：根据URL模板生成新的页面URL
'参数：URLTempleteURL模板
'PageIndex新的页码
'返回值：生成的URL
'涉及的表：无
'===================================================================================
PublicFunctionChangePage(URLTemplete,PageIndex)
ChangePage=SetQueryString(URLTemplete,"PAGE",PageIndex)
EndFunction
'===================================================================================
'函数原型：BuildPath(sPath)
'功能：根据指定的路径创建目录
'参数：sPathURL模板
'返回值：如果成功，返回空字符串，否则返回错误信息和错误位置
'涉及的表：无
'===================================================================================
PublicFunctionBuildPath(sPath)
DimiCnt
DimPath
DimBasePath
Path=Split(sPath,"/")
IfLeft(sPath,1)="/"orLeft(sPath,1)=""Then
BasePath=Server.MapPath("/")
Else
BasePath=Server.MapPath(".")
EndIf
DimcPath,oFso
cPath=BasePath
BuildPath=""
SetoFso=Server.CreateObject("Scripting.FileSystemObject")
ForiCnt=LBound(Path)ToUBound(Path)
IfTrim(Path(iCnt))<>""Then
cPath=cPath&""&Trim(Path(iCnt))
IfNotoFso.FolderExists(cPath)Then
OnErrorResumeNext
oFso.CreateFoldercPath
IfErr.Number<>0Then
BuildPath=Err.Description&"["&cPath&"]"
ExitFor
EndIf
OnErrorGoTo0
EndIf
EndIf
Next
SetoFso=Nothing
EndFunction
'===================================================================================
'函数原型：GetUserAgentInfo(ByRefvSoft,ByRefvOs)
'功能：获取客户端操作系统和浏览器信息
'参数：vSoft浏览器信息
'vOs操作系统信息
'返回值：无
'涉及的表：无
'===================================================================================
PublicFunctionGetUserAgentInfo(ByRefvSoft,ByRefvOs)
DimtheSoft
theSoft=Request.ServerVariables("HTTP_USER_AGENT")
'浏览器
IfInStr(theSoft,"NetCaptor")Then
vSoft="NetCaptor"
ElseIfInStr(theSoft,"MSIE6")Then
vSoft="MSIE6.0"
ElseIfInStr(theSoft,"MSIE5.5+")Then
vSoft="MSIE5.5"
ElseIfInStr(theSoft,"MSIE5")Then
vSoft="MSIE5.0"
ElseIfInStr(theSoft,"MSIE4")Then
vSoft="MSIE4.0"
ElseIfInStr(theSoft,"Netscape")Then
vSoft="Netscape"
ElseIfInStr(theSoft,"Opera")Then
vSoft="Opera"
Else
vSoft="Other"
EndIf
'操作系统
IfInStr(theSoft,"WindowsNT5.0")Then
vOs="Windows2000"
ElseIfInStr(theSoft,"WindowsNT5.1")Then
vOs="WindowsXP"
ElseIfInStr(theSoft,"WindowsNT5.2")Then
vOs="Windows2003"
ElseIfInStr(theSoft,"WindowsNT")Then
vOs="WindowsNT"
ElseIfInStr(theSoft,"Windows9")Then
vOs="Windows9x"
ElseIfInStr(theSoft,"unix")Then
vOs="Unix"
ElseIfInStr(theSoft,"linux")Then
vOs="Linux"
ElseIfInStr(theSoft,"SunOS")Then
vOs="SunOS"
ElseIfInStr(theSoft,"BSD")Then
vOs="BSD"
ElseIfInStr(theSoft,"Mac")Then
vOs="Mac"
Else
vOs="Other"
EndIf
EndFunction
'===================================================================================
'函数原型：GetRegexpObject()
'功能：获得一个正则表达式对象
'参数：无
'返回值：正则表达式对象
'涉及的表：无
'===================================================================================
PublicFunctionGetRegExpObject(sPattern)
Dimr
Setr=NewRegExp
r.Global=True
r.IgnoreCase=True
r.MultiLine=True
r.Pattern=sPattern
SetGetRegexpObject=r
Setr=Nothing
EndFunction
'===================================================================================
'函数原型：RegExpTest(pattern,string)
'功能：正则表达式检测
'参数：pattern模式字符串
'string待检查的字符串
'返回值：是否匹配
'涉及的表：无
'===================================================================================
PublicFunctionRegExpTest(p,s)
Dimr
Setr=GetRegExpObject(p)
RegExpTest=r.Test(s)
Setr=Nothing
EndFunction
'===================================================================================
'函数原型：RegExpReplace(sSource,sPattern,sRep)
'功能：正则表达式替换
'参数：sSource要替换的源字符串
'sPattern模式字符串
'sRep要替换的目标字符串
'返回值：替换后的字符串
'涉及的表：无
'===================================================================================
PublicFunctionRegExpReplace(sSource,sPattern,sRep)
Dimr
Setr=GetRegExpTest(sPattern)
RegExpReplace=r.Replace(sSource,sRep)
Setr=Nothing
EndFunction
'===================================================================================
'函数原型：CreateXMLParser()
'功能：创建一个尽可能高版本的XMLDOM
'参数：无
'返回值：IDOMDocument对象
'涉及的表：无
'===================================================================================
PublicFunctionCreateXMLParser()
OnErrorResumeNext
SetCreateXMLParser=Server.CreateObject("MSXML2.DOMDocument.4.0")
IfErr.Number<>0Then
Err.Clear
SetCreateXMLParser=Server.CreateObject("MSXML2.DOMDocument.3.0")
IfErr.Number<>0Then
Err.Clear
SetCreateXMLParser=Server.CreateObject("MSXML2.DOMDocument.2.6")
IfErr.Number<>0Then
Err.Clear
SetCreateXMLParser=Server.CreateObject("MSXML2.DOMDocument")
IfErr.Number<>0Then
Err.Clear
SetCreateXMLParser=Server.CreateObject("Microsoft.XMLDOM")
IfErr.Number<>0Then
Err.Clear
SetCreateXMLParser=Nothing
Else
ExitFunction
EndIf
Else
ExitFunction
EndIf
Else
ExitFunction
EndIf
Else
ExitFunction
EndIf
Else
ExitFunction
EndIf
OnErrorGoTo0
EndFunction
'===================================================================================
'函数原型：CreateHTTPPoster()
'功能：创建一个尽可能高版本的XMLHTTP
'参数：ServerOrClient创建ServerXMLHTTP还是XMLHTTP
'返回值：IXMLHTTP对象
'涉及的表：无
'===================================================================================
PublicFunctionCreateHTTPPoster(soc)
Dims
IfsocThen
s="ServerXMLHTTP"
Else
s="XMLHTTP"
EndIf
OnErrorResumeNext
SetCreateHTTPPoster=Server.CreateObject("MSXML2."&s&".4.0")
IfErr.Number<>0Then
Err.Clear
SetCreateHTTPPoster=Server.CreateObject("MSXML2."&s&".3.0")
IfErr.Number<>0Then
Err.Clear
SetCreateHTTPPoster=Server.CreateObject("MSXML2."&s)
IfErr.Number<>0Then
SetCreateHTTPPoster=Nothing
Else
ExitFunction
EndIf
Else
ExitFunction
EndIf
Else
ExitFunction
EndIf
OnErrorGoTo0
EndFunction
'===================================================================================
'函数原型：XMLThrowError(errCode,errReason)
'功能：抛出一个XML错误消息
'参数：errCode错误编码
'errReason错误原因
'返回值：无
'涉及的表：无
'===================================================================================
PublicSubXMLThrowError(errCode,errReason)
Response.Clear
Response.ContentType="text/xml"
Response.Write"<?xmlversion=""1.0""encoding=""gb2312""standalone=""yes""?>"&vbCrLf&_
"<ERRORCODE="""&errCode&"""REASON="""&errReason&"""/>"&vbCrLf
Response.Flush
Response.End
EndSub
'===================================================================================
'函数原型：GetXMLNodeValue(ByRefxmlDom,sFilter,sDefValue)
'功能：从一个XML文档中查找指定节点的值
'参数：xmlDomXML文档
'sFilterXPATH定位字符串
'sDefValue默认值
'返回值：无
'涉及的表：无
'===================================================================================
PublicFunctionGetXMLNodeValue(ByRefxmlDom,sFilter,sDefValue)
DimoNode
SetoNode=xmlDom.selectSingleNode(sFilter)
IfTypeName(oNode)="Nothing"orTypeName(oNode)="Null"orTypeName(oNode)="Empty"Then
GetXMLNodeValue=sDefValue
SetoNode=Nothing
Else
GetXMLNodeValue=Trim(oNode.Text)
SetoNode=Nothing
EndIf
EndFunction
'===================================================================================
'函数原型：GetXMLNodeAttribute(ByRefxmlDom,sFilter,sName,sDefValue)
'功能：从一个XML文档中查找指定节点的指定属性
'参数：xmlDomXML文档
'sFilterXPATH定位字符串
'sName要查询的属性名称
'sDefValue默认值
'返回值：无
'涉及的表：无
'===================================================================================
PublicFunctionGetXMLNodeAttribute(ByRefxmlDom,sFilter,sName,sDefValue)
DimoNode
SetoNode=xmlDom.selectSingleNode(sFilter)
IfTypeName(oNode)="Nothing"orTypeName(oNode)="Null"orTypeName(oNode)="Empty"Then
GetXMLNodeAttribute=sDefValue
SetoNode=Nothing
Else
DimpTemp
SetpTemp=oNode.getAttribute(sName)
IfTypeName(pTemp)="Nothing"orTypeName(pTemp)="Null"orTypeName(pTemp)="Empty"Then
GetXMLNodeAttribute=sDefValue
SetoNode=Nothing
SetpTemp=Nothing
Else
GetXMLNodeAttribute=Trim(pTemp.Value)
SetoNode=Nothing
SetpTemp=Nothing
EndIf
EndIf
EndFunction
'===================================================================================
'函数原型：GetQueryStringNumber(FieldName,defValue)
'功能：从QueryString获取一个整数
'参数：FieldName参数名
'defValue默认值
'返回值：无
'涉及的表：无
'===================================================================================
PublicFunctionGetQueryStringNumber(FieldName,defValue)
Dimr
r=Request.QueryString(FieldName)
Ifr=""Then
GetQueryStringNumber=defValue
ExitFunction
Else
IfNotIsNumeric(r)Then
GetQueryStringNumber=defValue
ExitFunction
Else
OnErrorResumeNext
r=CDbl(r)
IfErr.Number<>0Then
Err.Clear
GetQueryStringNumber=defValue
ExitFunction
Else
GetQueryStringNumber=r
EndIf
OnErrorGoTo0
EndIf
EndIf
EndFunction
'===================================================================================
'函数原型：IIf(testExpr,value1,value2)
'功能：相当于C/C++里面的?:运算符
'参数：testExprBoolean表达式
'value1testExpr=True时的取值
'value2testExpr=False时的取值
'返回值：如果testExpr为True返回value1否则返回value2
'涉及的表：无
'说明：VBScript里没有Iif函数
'===================================================================================
PublicFunctionIIf(testExpr,value1,value2)
IftestExpr=TrueThen
IIf=value1
Else
IIf=value2
EndIf
EndFunction
'===================================================================================
'函数原型：URLEncoding(v,f)
'功能：URL编码函数
'参数：v中英文混合字符串
'f是否对ASCII字符编码
'返回值：编码后的ASC字符串
'涉及的表：无
'===================================================================================
PublicFunctionURLEncoding(v,f)
Dims,t,i,j,h,l,x
s=""
x=Len(v)
Fori=1Tox
t=Mid(v,i,1)
j=Asc(t)
Ifj>0Then
IffThen
s=s&"%"&Right("00"&Hex(Asc(t)),2)
Else
s=s&t
EndIf
Else
Ifj<0Thenj=j+&H10000
h=(jAnd&HFF00)&HFF
l=jAnd&HFF
s=s&"%"&Hex(h)&"%"&Hex(l)
EndIf
Next
URLEncoding=s
EndFunction
'===================================================================================
'函数原型：URLDecoding(sIn)
'功能：URL解码码函数
'参数：vURL编码的字符串
'返回值：解码后的字符串
'涉及的表：无
'===================================================================================
PublicFunctionURLDecoding(Sin)
Dims,i,l,c,t,n
s=""
l=Len(Sin)
Fori=1Tol
c=Mid(Sin,i,1)
Ifc<>"%"Then
s=s&c
Else
c=Mid(Sin,i+1,2)
i=i+2
t=CInt("&H"&c)
Ift<&H80Then
s=s&Chr(t)
Else
c=Mid(Sin,i+1,3)
IfLeft(c,1)<>"%"Then
URLDecoding=s
ExitFunction
Else
c=Right(c,2)
n=CInt("&H"&c)
t=t*256+n-65536
s=s&Chr(t)
i=i+3
EndIf
EndIf
EndIf
Next
URLDecoding=s
EndFunction
'===================================================================================
'函数原型：Bytes2BSTR(v)
'功能：UTF-8编码转换到正常的GB2312
'参数：vUTF-8编码字节流
'返回值：解码后的字符串
'涉及的表：无
'===================================================================================
PublicFunctionBytes2BSTR(v)
Dimr,i,t,n
r=""
Fori=1ToLenB(v)
t=AscB(MidB(v,i,1))
Ift<&H80Then
r=r&Chr(t)
Else
n=AscB(MidB(v,i+1,1))
r=r&Chr(CLng(t)*&H100+CInt(n))
i=i+1
EndIf
Next
Bytes2BSTR=r
EndFunction
%>