ASP常用函數(shù)收藏亂七八糟未整理版
更新時(shí)間：2007年02月07日 00:00:00 作者：
<%
'*******************************************************************
'取得IP地址
'*******************************************************************
Function Userip()
Dim GetClientIP
'如果客戶端用了代理服務(wù)器，則應(yīng)該用ServerVariables("HTTP_X_FORWARDED_FOR")方法
GetClientIP = Request.ServerVariables("HTTP_X_FORWARDED_FOR")
If GetClientIP = "" or IsNull(GetClientIP) or IsEmpty(GetClientIP) Then
'如果客戶端沒用代理，應(yīng)該用Request.ServerVariables("REMOTE_ADDR")方法
GetClientIP = Request.ServerVariables("REMOTE_ADDR")
End If
Userip = GetClientIP
End Function
'*******************************************************************
'轉(zhuǎn)換IP地址
'*******************************************************************
Function cip(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)
End Function
'*******************************************************************
' 彈出對(duì)話框
'*******************************************************************
Sub alert(message)
message = Replace(message, "'", "\'")
Response.Write ("<script>alert('" & message & "')</script>")
End Sub
'*******************************************************************
' 返回上一頁(yè)，一般用在判斷信息提交是否完全之后
'*******************************************************************
Sub GoBack()
Response.Write ("<script>history.go(-1)</script>")
End Sub
'*******************************************************************
' 重定向另外的連接
'*******************************************************************
Sub Go(url)
Response.Write ("<script>location.href('" & url & "')</script>")
End Sub
'*******************************************************************
' 我比較喜歡將以上三個(gè)結(jié)合起來(lái)使用
'*******************************************************************
Function Alert(message, gourl)
message = Replace(message, "'", "\'")
If gourl = "-1" Then
Response.Write ("<script language=javascript>alert('" & message & "');history.go(-1)</script>")
Else
Response.Write ("<script language=javascript>alert('" & message & "');location='" & gourl &"'</script>")
End If
Response.End()
End Function
'*******************************************************************
' 指定秒數(shù)重定向另外的連接
'*******************************************************************
Sub GoPage(url, s)
s = s * 1000
Response.Write "<SCRIPT LANGUAGE=JavaScript>"
Response.Write "window.setTimeout("&Chr(34)&"window.navigate('"&url&"')"&Chr(34)&","&s&")"
Response.Write "</script>"
End Sub
'*******************************************************************
' 判斷數(shù)字是否整形
'*******************************************************************
Function isInteger(para)
On Error Resume Next
Dim Str
Dim l, i
If IsNull(para) Then
isInteger = False
Exit Function
End If
Str = CStr(para)
If Trim(Str) = "" Then
isInteger = False
Exit Function
End If
l = Len(Str)
For i = 1 To l
If Mid(Str, i, 1)>"9" or Mid(Str, i, 1)<"0" Then
isInteger = False
Exit Function
End If
Next
isInteger = True
If Err.Number<>0 Then Err.Clear
End Function
'*******************************************************************
' 獲得文件擴(kuò)展名
'*******************************************************************
Function GetExtend(filename)
Dim tmp
If filename<>"" Then
tmp = Mid(filename, instrrev(filename, ".") + 1, Len(filename) - instrrev(filename, "."))
tmp = LCase(tmp)
If InStr(1, tmp, "asp")>0 or InStr(1, tmp, "php")>0 or InStr(1, tmp, "php3")>0 or InStr(1, tmp, "aspx")>0 Then
getextend = "txt"
Else
getextend = tmp
End If
Else
getextend = ""
End If
End Function
' *----------------------------------------------------------------------------
' * 函數(shù)：CheckIn
' * 描述：檢測(cè)參數(shù)是否有SQL危險(xiǎn)字符
' * 參數(shù)：str要檢測(cè)的數(shù)據(jù)
' * 返回：FALSE：安全 TRUE：不安全
' * 作者：
' * 日期：
' *----------------------------------------------------------------------------
Function CheckIn(Str)
If InStr(1, Str, Chr(39))>0 or InStr(1, Str, Chr(34))>0 or InStr(1, Str, Chr(59))>0 Then
CheckIn = True
Else
CheckIn = False
End If
End Function
' *----------------------------------------------------------------------------
' * 函數(shù)：HTMLEncode
' * 描述：過(guò)濾HTML代碼
' * 參數(shù)：--
' * 返回：--
' * 作者：
' * 日期：
' *----------------------------------------------------------------------------
Function HTMLEncode(fString)
If Not IsNull(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
End If
End Function
' *----------------------------------------------------------------------------
' * 函數(shù)：HTMLcode
' * 描述：過(guò)濾表單字符
' * 參數(shù)：--
' * 返回：--
' * 作者：
' * 日期：
' *----------------------------------------------------------------------------
Function HTMLcode(fString)
If Not IsNull(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
End If
End Function
%>
<%
1.檢查是否有效郵件地址
Function CheckEmail(strEmail)
Dim re
Set re = New RegExp
re.Pattern = "^[w-.]{1,}@([da-zA-Z-]{1,}.){1,}[da-zA-Z-]{2,3}$"
re.IgnoreCase = True
CheckEmail = re.Test(strEmail)
End Function
2.測(cè)試變量是否為空值，空值的含義包括：變量不存在 / 為空，對(duì)象為Nothing，0，空數(shù)組，字符串為空
Function IsBlank(ByRef Var)
IsBlank = False
Select Case True
Case IsObject(Var)
If Var Is Nothing Then IsBlank = True
Case IsEmpty(Var), IsNull(Var)
IsBlank = True
Case IsArray(Var)
If UBound(Var) = 0 Then IsBlank = True
Case IsNumeric(Var)
If (Var = 0) Then IsBlank = True
Case Else
If Trim(Var) = "" Then IsBlank = True
End Select
End Function
3.得到瀏覽器目前的URL
Function GetCurURL()
If Request.ServerVariables("HTTPS") = "on" Then
GetCurrentURL = "https://"
Else
GetCurrentURL = "http://"
End If
GetCurURL = GetCurURL & Request.ServerVariables("SERVER_NAME")
If (Request.ServerVariables("SERVER_PORT") <> 80) Then GetCurURL = GetCurURL & ":" & Request.ServerVariables("SERVER_PORT")
GetCurURL = GetCurURL & Request.ServerVariables("URL")
If (Request.QueryString <> "") Then GetCurURL = GetCurURL & "?" & Request.QueryString
End Function
4.MD5加密函數(shù)
Private Const BITS_TO_A_BYTE = 8
Private Const BYTES_TO_A_WORD = 4
Private Const BITS_TO_A_WORD = 32
Private m_lOnBits(30)
Private m_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)
Private Function LShift(lValue, iShiftBits)
If iShiftBits = 0 Then
LShift = lValue
Exit Function
ElseIf iShiftBits = 31 Then
If lValue And 1 Then
LShift = &H80000000
Else
LShift = 0
End If
Exit Function
ElseIf iShiftBits < 0 or iShiftBits > 31 Then
Err.Raise 6
End If
If (lValue And m_l2Power(31 - iShiftBits)) Then
LShift = ((lValue And m_lOnBits(31 - (iShiftBits + 1))) * m_l2Power(iShiftBits)) or &H80000000
Else
LShift = ((lValue And m_lOnBits(31 - iShiftBits)) * m_l2Power(iShiftBits))
End If
End Function
Private Function RShift(lValue, iShiftBits)
If iShiftBits = 0 Then
RShift = lValue
Exit Function
ElseIf iShiftBits = 31 Then
If lValue And &H80000000 Then
RShift = 1
Else
RShift = 0
End If
Exit Function
ElseIf iShiftBits < 0 or iShiftBits > 31 Then
Err.Raise 6
End If
RShift = (lValue And &H7FFFFFFE) m_l2Power(iShiftBits)
If (lValue And &H80000000) Then
RShift = (RShift or (&H40000000 m_l2Power(iShiftBits - 1)))
End If
End Function
Private Function RotateLeft(lValue, iShiftBits)
RotateLeft = LShift(lValue, iShiftBits) or RShift(lValue, (32 - iShiftBits))
End Function
Private Function AddUnsigned(lX, lY)
Dim lX4
Dim lY4
Dim lX8
Dim lY8
Dim lResult
lX8 = lX And &H80000000
lY8 = lY And &H80000000
lX4 = lX And &H40000000
lY4 = lY And &H40000000
lResult = (lX And &H3FFFFFFF) + (lY And &H3FFFFFFF)
If lX4 And lY4 Then
lResult = lResult Xor &H80000000 Xor lX8 Xor lY8
ElseIf lX4 or lY4 Then
If lResult And &H40000000 Then
lResult = lResult Xor &HC0000000 Xor lX8 Xor lY8
Else
lResult = lResult Xor &H40000000 Xor lX8 Xor lY8
End If
Else
lResult = lResult Xor lX8 Xor lY8
End If
AddUnsigned = lResult
End Function
Private Function F(x, y, z)
F = (x And y) or ((Not x) And z)
End Function
Private Function G(x, y, z)
G = (x And z) or (y And (Not z))
End Function
Private Function H(x, y, z)
H = (x Xor y Xor z)
End Function
Private Function I(x, y, z)
I = (y Xor (x or (Not z)))
End Function
Private Sub FF(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)
End Sub
Private Sub GG(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)
End Sub
Private Sub HH(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)
End Sub
Private Sub II(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)
End Sub
Private Function ConvertToWordArray(sMessage)
Dim lMessageLength
Dim lNumberOfWords
Dim lWordArray()
Dim lBytePosition
Dim lByteCount
Dim lWordCount
Const MODULUS_BITS = 512
Const CONGRUENT_BITS = 448
lMessageLength = Len(sMessage)
lNumberOfWords = (((lMessageLength + ((MODULUS_BITS - CONGRUENT_BITS) BITS_TO_A_BYTE)) (MODULUS_BITS BITS_TO_A_BYTE)) + 1) * (MODULUS_BITS BITS_TO_A_WORD)
ReDim lWordArray(lNumberOfWords - 1)
lBytePosition = 0
lByteCount = 0
Do Until lByteCount >= lMessageLength
lWordCount = lByteCount BYTES_TO_A_WORD
lBytePosition = (lByteCount Mod BYTES_TO_A_WORD) * BITS_TO_A_BYTE
lWordArray(lWordCount) = lWordArray(lWordCount) or LShift(Asc(Mid(sMessage, lByteCount + 1, 1)), lBytePosition)
lByteCount = lByteCount + 1
Loop
lWordCount = lByteCount BYTES_TO_A_WORD
lBytePosition = (lByteCount Mod BYTES_TO_A_WORD) * BITS_TO_A_BYTE
lWordArray(lWordCount) = lWordArray(lWordCount) or LShift(&H80, lBytePosition)
lWordArray(lNumberOfWords - 2) = LShift(lMessageLength, 3)
lWordArray(lNumberOfWords - 1) = RShift(lMessageLength, 29)
ConvertToWordArray = lWordArray
End Function
Private Function WordToHex(lValue)
Dim lByte
Dim lCount
For lCount = 0 To 3
lByte = RShift(lValue, lCount * BITS_TO_A_BYTE) And m_lOnBits(BITS_TO_A_BYTE - 1)
WordToHex = WordToHex & Right("0" & Hex(lByte), 2)
Next
End Function
Public Function MD5(sMessage)
Dim x
Dim k
Dim AA
Dim BB
Dim CC
Dim DD
Dim a
Dim b
Dim c
Dim d
Const S11 = 7
Const S12 = 12
Const S13 = 17
Const S14 = 22
Const S21 = 5
Const S22 = 9
Const S23 = 14
Const S24 = 20
Const S31 = 4
Const S32 = 11
Const S33 = 16
Const S34 = 23
Const S41 = 6
Const S42 = 10
Const S43 = 15
Const S44 = 21
x = ConvertToWordArray(sMessage)
a = &H67452301
b = &HEFCDAB89
c = &H98BADCFE
d = &H10325476
For k = 0 To UBound(x) Step 16
AA = a
BB = b
CC = c
DD = d
FF a, b, c, d, x(k + 0), S11, &HD76AA478
FF d, a, b, c, x(k + 1), S12, &HE8C7B756
FF c, d, a, b, x(k + 2), S13, &H242070DB
FF b, c, d, a, x(k + 3), S14, &HC1BDCEEE
FF a, b, c, d, x(k + 4), S11, &HF57C0FAF
FF d, a, b, c, x(k + 5), S12, &H4787C62A
FF c, d, a, b, x(k + 6), S13, &HA8304613
FF b, c, d, a, x(k + 7), S14, &HFD469501
FF a, b, c, d, x(k + 8), S11, &H698098D8
FF d, a, b, c, x(k + 9), S12, &H8B44F7AF
FF c, d, a, b, x(k + 10), S13, &HFFFF5BB1
FF b, c, d, a, x(k + 11), S14, &H895CD7BE
FF a, b, c, d, x(k + 12), S11, &H6B901122
FF d, a, b, c, x(k + 13), S12, &HFD987193
FF c, d, a, b, x(k + 14), S13, &HA679438E
FF b, c, d, a, x(k + 15), S14, &H49B40821
GG a, b, c, d, x(k + 1), S21, &HF61E2562
GG d, a, b, c, x(k + 6), S22, &HC040B340
GG c, d, a, b, x(k + 11), S23, &H265E5A51
GG b, c, d, a, x(k + 0), S24, &HE9B6C7AA
GG a, b, c, d, x(k + 5), S21, &HD62F105D
GG d, a, b, c, x(k + 10), S22, &H2441453
GG c, d, a, b, x(k + 15), S23, &HD8A1E681
GG b, c, d, a, x(k + 4), S24, &HE7D3FBC8
GG a, b, c, d, x(k + 9), S21, &H21E1CDE6
GG d, a, b, c, x(k + 14), S22, &HC33707D6
GG c, d, a, b, x(k + 3), S23, &HF4D50D87
GG b, c, d, a, x(k + 8), S24, &H455A14ED
GG a, b, c, d, x(k + 13), S21, &HA9E3E905
GG d, a, b, c, x(k + 2), S22, &HFCEFA3F8
GG c, d, a, b, x(k + 7), S23, &H676F02D9
GG b, c, d, a, x(k + 12), S24, &H8D2A4C8A
HH a, b, c, d, x(k + 5), S31, &HFFFA3942
HH d, a, b, c, x(k + 8), S32, &H8771F681
HH c, d, a, b, x(k + 11), S33, &H6D9D6122
HH b, c, d, a, x(k + 14), S34, &HFDE5380C
HH a, b, c, d, x(k + 1), S31, &HA4BEEA44
HH d, a, b, c, x(k + 4), S32, &H4BDECFA9
HH c, d, a, b, x(k + 7), S33, &HF6BB4B60
HH b, c, d, a, x(k + 10), S34, &HBEBFBC70
HH a, b, c, d, x(k + 13), S31, &H289B7EC6
HH d, a, b, c, x(k + 0), S32, &HEAA127FA
HH c, d, a, b, x(k + 3), S33, &HD4EF3085
HH b, c, d, a, x(k + 6), S34, &H4881D05
HH a, b, c, d, x(k + 9), S31, &HD9D4D039
HH d, a, b, c, x(k + 12), S32, &HE6DB99E5
HH c, d, a, b, x(k + 15), S33, &H1FA27CF8
HH b, c, d, a, x(k + 2), S34, &HC4AC5665
II a, b, c, d, x(k + 0), S41, &HF4292244
II d, a, b, c, x(k + 7), S42, &H432AFF97
II c, d, a, b, x(k + 14), S43, &HAB9423A7
II b, c, d, a, x(k + 5), S44, &HFC93A039
II a, b, c, d, x(k + 12), S41, &H655B59C3
II d, a, b, c, x(k + 3), S42, &H8F0CCC92
II c, d, a, b, x(k + 10), S43, &HFFEFF47D
II b, c, d, a, x(k + 1), S44, &H85845DD1
II a, b, c, d, x(k + 8), S41, &H6FA87E4F
II d, a, b, c, x(k + 15), S42, &HFE2CE6E0
II c, d, a, b, x(k + 6), S43, &HA3014314
II b, c, d, a, x(k + 13), S44, &H4E0811A1
II a, b, c, d, x(k + 4), S41, &HF7537E82
II d, a, b, c, x(k + 11), S42, &HBD3AF235
II c, d, a, b, x(k + 2), S43, &H2AD7D2BB
II b, 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))
End Function
5.SHA256 加密，256位的加密哦！安全性更高！
Private m_lOnBits(30)
Private m_l2Power(30)
Private K(63)
Private Const BITS_TO_A_BYTE = 8
Private Const BYTES_TO_A_WORD = 4
Private Const BITS_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
Private Function LShift(lValue, iShiftBits)
If iShiftBits = 0 Then
LShift = lValue
Exit Function
ElseIf iShiftBits = 31 Then
If lValue And 1 Then
LShift = &H80000000
Else
LShift = 0
End If
Exit Function
ElseIf iShiftBits < 0 or iShiftBits > 31 Then
Err.Raise 6
End If
If (lValue And m_l2Power(31 - iShiftBits)) Then
LShift = ((lValue And m_lOnBits(31 - (iShiftBits + 1))) * m_l2Power(iShiftBits)) or &H80000000
Else
LShift = ((lValue And m_lOnBits(31 - iShiftBits)) * m_l2Power(iShiftBits))
End If
End Function
Private Function RShift(lValue, iShiftBits)
If iShiftBits = 0 Then
RShift = lValue
Exit Function
ElseIf iShiftBits = 31 Then
If lValue And &H80000000 Then
RShift = 1
Else
RShift = 0
End If
Exit Function
ElseIf iShiftBits < 0 or iShiftBits > 31 Then
Err.Raise 6
End If
RShift = (lValue And &H7FFFFFFE) m_l2Power(iShiftBits)
If (lValue And &H80000000) Then
RShift = (RShift or (&H40000000 m_l2Power(iShiftBits - 1)))
End If
End Function
Private Function AddUnsigned(lX, lY)
Dim lX4
Dim lY4
Dim lX8
Dim lY8
Dim lResult
lX8 = lX And &H80000000
lY8 = lY And &H80000000
lX4 = lX And &H40000000
lY4 = lY And &H40000000
lResult = (lX And &H3FFFFFFF) + (lY And &H3FFFFFFF)
If lX4 And lY4 Then
lResult = lResult Xor &H80000000 Xor lX8 Xor lY8
ElseIf lX4 or lY4 Then
If lResult And &H40000000 Then
lResult = lResult Xor &HC0000000 Xor lX8 Xor lY8
Else
lResult = lResult Xor &H40000000 Xor lX8 Xor lY8
End If
Else
lResult = lResult Xor lX8 Xor lY8
End If
AddUnsigned = lResult
End Function
Private Function Ch(x, y, z)
Ch = ((x And y) Xor ((Not x) And z))
End Function
Private Function Maj(x, y, z)
Maj = ((x And y) Xor (x And z) Xor (y And z))
End Function
Private Function S(x, n)
S = (RShift(x, (n And m_lOnBits(4))) or LShift(x, (32 - (n And m_lOnBits(4)))))
End Function
Private Function R(x, n)
R = RShift(x, CInt(n And m_lOnBits(4)))
End Function
Private Function Sigma0(x)
Sigma0 = (S(x, 2) Xor S(x, 13) Xor S(x, 22))
End Function
Private Function Sigma1(x)
Sigma1 = (S(x, 6) Xor S(x, 11) Xor S(x, 25))
End Function
Private Function Gamma0(x)
Gamma0 = (S(x, 7) Xor S(x, 18) Xor R(x, 3))
End Function
Private Function Gamma1(x)
Gamma1 = (S(x, 17) Xor S(x, 19) Xor R(x, 10))
End Function
Private Function ConvertToWordArray(sMessage)
Dim lMessageLength
Dim lNumberOfWords
Dim lWordArray()
Dim lBytePosition
Dim lByteCount
Dim lWordCount
Dim lByte
Const MODULUS_BITS = 512
Const CONGRUENT_BITS = 448
lMessageLength = Len(sMessage)
lNumberOfWords = (((lMessageLength + ((MODULUS_BITS - CONGRUENT_BITS) BITS_TO_A_BYTE)) (MODULUS_BITS BITS_TO_A_BYTE)) + 1) * (MODULUS_BITS BITS_TO_A_WORD)
ReDim lWordArray(lNumberOfWords - 1)
lBytePosition = 0
lByteCount = 0
Do Until lByteCount >= lMessageLength
lWordCount = lByteCount BYTES_TO_A_WORD
lBytePosition = (3 - (lByteCount Mod BYTES_TO_A_WORD)) * BITS_TO_A_BYTE
lByte = AscB(Mid(sMessage, lByteCount + 1, 1))
lWordArray(lWordCount) = lWordArray(lWordCount) or LShift(lByte, lBytePosition)
lByteCount = lByteCount + 1
Loop
lWordCount = lByteCount BYTES_TO_A_WORD
lBytePosition = (3 - (lByteCount Mod BYTES_TO_A_WORD)) * BITS_TO_A_BYTE
lWordArray(lWordCount) = lWordArray(lWordCount) or LShift(&H80, lBytePosition)
lWordArray(lNumberOfWords - 1) = LShift(lMessageLength, 3)
lWordArray(lNumberOfWords - 2) = RShift(lMessageLength, 29)
ConvertToWordArray = lWordArray
End Function
Public Function SHA256(sMessage)
Dim HASH(7)
Dim M
Dim W(63)
Dim a
Dim b
Dim c
Dim d
Dim e
Dim f
Dim g
Dim h
Dim i
Dim j
Dim T1
Dim T2
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)
For i = 0 To UBound(M) Step 16
a = HASH(0)
b = HASH(1)
c = HASH(2)
d = HASH(3)
e = HASH(4)
f = HASH(5)
g = HASH(6)
h = HASH(7)
For j = 0 To 63
If j < 16 Then
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))
End If
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))
End Function
6.一個(gè)If語(yǔ)句的加工，以后可以用類似于PHP或JS的 If () ? ..
...代碼了
Function IIf(Condition, ValueIfTrue, ValueIfFalse)
If Condition Then
IIf = ValueIfTrue
Else
IIf = ValueIfFalse
End If
End Function
7.ASE加密函數(shù)
Private m_lOnBits(30)
Private m_l2Power(30)
Private m_bytOnBits(7)
Private m_byt2Power(7)
Private m_InCo(3)
Private m_fbsub(255)
Private m_rbsub(255)
Private m_ptab(255)
Private m_ltab(255)
Private m_ftable(255)
Private m_rtable(255)
Private m_rco(29)
Private m_Nk
Private m_Nb
Private m_Nr
Private m_fi(23)
Private m_ri(23)
Private m_fkey(119)
Private m_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
Private Function LShift(lValue, iShiftBits)
If iShiftBits = 0 Then
LShift = lValue
Exit Function
ElseIf iShiftBits = 31 Then
If lValue And 1 Then
LShift = &H80000000
Else
LShift = 0
End If
Exit Function
ElseIf iShiftBits < 0 or iShiftBits > 31 Then
Err.Raise 6
End If
If (lValue And m_l2Power(31 - iShiftBits)) Then
LShift = ((lValue And m_lOnBits(31 - (iShiftBits + 1))) * m_l2Power(iShiftBits)) or &H80000000
Else
LShift = ((lValue And m_lOnBits(31 - iShiftBits)) * m_l2Power(iShiftBits))
End If
End Function
Private Function RShift(lValue, iShiftBits)
If iShiftBits = 0 Then
RShift = lValue
Exit Function
ElseIf iShiftBits = 31 Then
If lValue And &H80000000 Then
RShift = 1
Else
RShift = 0
End If
Exit Function
ElseIf iShiftBits < 0 or iShiftBits > 31 Then
Err.Raise 6
End If
RShift = (lValue And &H7FFFFFFE) m_l2Power(iShiftBits)
If (lValue And &H80000000) Then
RShift = (RShift or (&H40000000 m_l2Power(iShiftBits - 1)))
End If
End Function
Private Function LShiftByte(bytValue, bytShiftBits)
If bytShiftBits = 0 Then
LShiftByte = bytValue
Exit Function
ElseIf bytShiftBits = 7 Then
If bytValue And 1 Then
LShiftByte = &H80
Else
LShiftByte = 0
End If
Exit Function
ElseIf bytShiftBits < 0 or bytShiftBits > 7 Then
Err.Raise 6
End If
LShiftByte = ((bytValue And m_bytOnBits(7 - bytShiftBits)) * m_byt2Power(bytShiftBits))
End Function
Private Function RShiftByte(bytValue, bytShiftBits)
If bytShiftBits = 0 Then
RShiftByte = bytValue
Exit Function
ElseIf bytShiftBits = 7 Then
If bytValue And &H80 Then
RShiftByte = 1
Else
RShiftByte = 0
End If
Exit Function
ElseIf bytShiftBits < 0 or bytShiftBits > 7 Then
Err.Raise 6
End If
RShiftByte = bytValue m_byt2Power(bytShiftBits)
End Function
Private Function RotateLeft(lValue, iShiftBits)
RotateLeft = LShift(lValue, iShiftBits) or RShift(lValue, (32 - iShiftBits))
End Function
Private Function RotateLeftByte(bytValue, bytShiftBits)
RotateLeftByte = LShiftByte(bytValue, bytShiftBits) or RShiftByte(bytValue, (8 - bytShiftBits))
End Function
Private Function Pack(b())
Dim lCount
Dim lTemp
For lCount = 0 To 3
lTemp = b(lCount)
Pack = Pack or LShift(lTemp, (lCount * 8))
Next
End Function
Private Function PackFrom(b(), k)
Dim lCount
Dim lTemp
For lCount = 0 To 3
lTemp = b(lCount + k)
PackFrom = PackFrom or LShift(lTemp, (lCount * 8))
Next
End Function
Private Sub Unpack(a, b())
b(0) = a And m_lOnBits(7)
b(1) = RShift(a, 8) And m_lOnBits(7)
b(2) = RShift(a, 16) And m_lOnBits(7)
b(3) = RShift(a, 24) And m_lOnBits(7)
End Sub
Private Sub UnpackFrom(a, b(), k)
b(0 + k) = a And m_lOnBits(7)
b(1 + k) = RShift(a, 8) And m_lOnBits(7)
b(2 + k) = RShift(a, 16) And m_lOnBits(7)
b(3 + k) = RShift(a, 24) And m_lOnBits(7)
End Sub
Private Function xtime(a)
Dim b
If (a And &H80) Then
b = &H1B
Else
b = 0
End If
xtime = LShiftByte(a, 1)
xtime = xtime Xor b
End Function
Private Function bmul(x, y)
If x <> 0 And y <> 0 Then
bmul = m_ptab((CLng(m_ltab(x)) + CLng(m_ltab(y))) Mod 255)
Else
bmul = 0
End If
End Function
Private Function SubByte(a)
Dim b(3)
Unpack a, 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)
End Function
Private Function product(x, y)
Dim xb(3)
Dim yb(3)
Unpack x, xb
Unpack y, yb
product = bmul(xb(0), yb(0)) Xor bmul(xb(1), yb(1)) Xor bmul(xb(2), yb(2)) Xor bmul(xb(3), yb(3))
End Function
Private Function InvMixCol(x)
Dim y
Dim m
Dim b(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
End Function
Private Function ByteSub(x)
Dim y
Dim z
z = x
y = m_ptab(255 - m_ltab(z))
z = y
z = RotateLeftByte(z, 1)
y = y Xor z
z = RotateLeftByte(z, 1)
y = y Xor z
z = RotateLeftByte(z, 1)
y = y Xor z
z = RotateLeftByte(z, 1)
y = y Xor z
y = y Xor &H63
ByteSub = y
End Function
Public Sub gentables()
Dim i
Dim y
Dim b(3)
Dim ib
m_ltab(0) = 0
m_ptab(0) = 1
m_ltab(1) = 0
m_ptab(1) = 3
m_ltab(3) = 1
For i = 2 To 255
m_ptab(i) = m_ptab(i - 1) Xor xtime(m_ptab(i - 1))
m_ltab(m_ptab(i)) = i
Next
m_fbsub(0) = &H63
m_rbsub(&H63) = 0
For i = 1 To 255
ib = i
y = ByteSub(ib)
m_fbsub(i) = y
m_rbsub(y) = i
Next
y = 1
For i = 0 To 29
m_rco(i) = y
y = xtime(y)
Next
For i = 0 To 255
y = m_fbsub(i)
b(3) = y Xor xtime(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
End Sub
Public Sub gkey(nb, nk, Key())
Dim i
Dim j
Dim k
Dim m
Dim N
Dim C1
Dim C2
Dim C3
Dim CipherKey(7)
m_Nb = nb
m_Nk = nk
If m_Nb >= m_Nk Then
m_Nr = 6 + m_Nb
Else
m_Nr = 6 + m_Nk
End If
C1 = 1
If m_Nb < 8 Then
C2 = 2
C3 = 3
Else
C2 = 3
C3 = 4
End If
For j = 0 To nb - 1
m = j * 3
m_fi(m) = (j + C1) Mod nb
m_fi(m + 1) = (j + C2) Mod nb
m_fi(m + 2) = (j + C3) Mod nb
m_ri(m) = (nb + j - C1) Mod nb
m_ri(m + 1) = (nb + j - C2) Mod nb
m_ri(m + 2) = (nb + j - C3) Mod nb
Next
N = m_Nb * (m_Nr + 1)
For i = 0 To m_Nk - 1
j = i * 4
CipherKey(i) = PackFrom(Key, j)
Next
For i = 0 To m_Nk - 1
m_fkey(i) = CipherKey(i)
Next
j = m_Nk
k = 0
Do While j < N
m_fkey(j) = m_fkey(j - m_Nk) Xor _
SubByte(RotateLeft(m_fkey(j - 1), 24)) Xor m_rco(k)
If m_Nk <= 6 Then
i = 1
Do While i < m_Nk And (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
Do While i < 4 And (i + j) < N
m_fkey(i + j) = m_fkey(i + j - m_Nk) Xor _
m_fkey(i + j - 1)
i = i + 1
Loop
If j + 4 < N Then
m_fkey(j + 4) = m_fkey(j + 4 - m_Nk) Xor _
SubByte(m_fkey(j + 3))
End If
i = 5
Do While i < m_Nk And (i + j) < N
m_fkey(i + j) = m_fkey(i + j - m_Nk) Xor _
m_fkey(i + j - 1)
i = i + 1
Loop
End If
j = j + m_Nk
k = k + 1
Loop
For j = 0 To m_Nb - 1
m_rkey(j + N - nb) = m_fkey(j)
Next
i = m_Nb
Do While i < N - m_Nb
k = N - m_Nb - i
For j = 0 To m_Nb - 1
m_rkey(k + j) = InvMixCol(m_fkey(i + j))
Next
i = i + m_Nb
Loop
j = N - m_Nb
Do While j < N
m_rkey(j - N + m_Nb) = m_fkey(j)
j = j + 1
Loop
End Sub
Public Sub encrypt(buff())
Dim i
Dim j
Dim k
Dim m
Dim a(7)
Dim b(7)
Dim x
Dim y
Dim t
For i = 0 To m_Nb - 1
j = i * 4
a(i) = PackFrom(buff, j)
a(i) = a(i) Xor m_fkey(i)
Next
k = m_Nb
x = a
y = b
For i = 1 To m_Nr - 1
For j = 0 To m_Nb - 1
m = j * 3
y(j) = m_fkey(k) Xor m_ftable(x(j) And m_lOnBits(7)) Xor _
RotateLeft(m_ftable(RShift(x(m_fi(m)), 8) And m_lOnBits(7)), 8) Xor _
RotateLeft(m_ftable(RShift(x(m_fi(m + 1)), 16) And m_lOnBits(7)), 16) Xor _
RotateLeft(m_ftable(RShift(x(m_fi(m + 2)), 24) And m_lOnBits(7)), 24)
k = k + 1
Next
t = x
x = y
y = t
Next
For j = 0 To m_Nb - 1
m = j * 3
y(j) = m_fkey(k) Xor m_fbsub(x(j) And m_lOnBits(7)) Xor _
RotateLeft(m_fbsub(RShift(x(m_fi(m)), 8) And m_lOnBits(7)), 8) Xor _
RotateLeft(m_fbsub(RShift(x(m_fi(m + 1)), 16) And m_lOnBits(7)), 16) Xor _
RotateLeft(m_fbsub(RShift(x(m_fi(m + 2)), 24) And m_lOnBits(7)), 24)
k = k + 1
Next
For i = 0 To m_Nb - 1
j = i * 4
UnpackFrom y(i), buff, j
x(i) = 0
y(i) = 0
Next
End Sub
Public Sub decrypt(buff())
Dim i
Dim j
Dim k
Dim m
Dim a(7)
Dim b(7)
Dim x
Dim y
Dim t
For i = 0 To m_Nb - 1
j = i * 4
a(i) = PackFrom(buff, j)
a(i) = a(i) Xor m_rkey(i)
Next
k = m_Nb
x = a
y = b
For i = 1 To m_Nr - 1
For j = 0 To m_Nb - 1
m = j * 3
y(j) = m_rkey(k) Xor m_rtable(x(j) And m_lOnBits(7)) Xor _
RotateLeft(m_rtable(RShift(x(m_ri(m)), 8) And m_lOnBits(7)), 8) Xor _
RotateLeft(m_rtable(RShift(x(m_ri(m + 1)), 16) And m_lOnBits(7)), 16) Xor _
RotateLeft(m_rtable(RShift(x(m_ri(m + 2)), 24) And m_lOnBits(7)), 24)
k = k + 1
Next
t = x
x = y
y = t
Next
For j = 0 To m_Nb - 1
m = j * 3
y(j) = m_rkey(k) Xor m_rbsub(x(j) And m_lOnBits(7)) Xor _
RotateLeft(m_rbsub(RShift(x(m_ri(m)), 8) And m_lOnBits(7)), 8) Xor _
RotateLeft(m_rbsub(RShift(x(m_ri(m + 1)), 16) And m_lOnBits(7)), 16) Xor _
RotateLeft(m_rbsub(RShift(x(m_ri(m + 2)), 24) And m_lOnBits(7)), 24)
k = k + 1
Next
For i = 0 To m_Nb - 1
j = i * 4
UnpackFrom y(i), buff, j
x(i) = 0
y(i) = 0
Next
End Sub
Private Function IsInitialized(vArray)
On Error Resume Next
IsInitialized = IsNumeric(UBound(vArray))
End Function
Private Sub CopyBytesASP(bytDest, lDestStart, bytSource(), lSourceStart, lLength)
Dim lCount
lCount = 0
Do
bytDest(lDestStart + lCount) = bytSource(lSourceStart + lCount)
lCount = lCount + 1
Loop Until lCount = lLength
End Sub
Public Function EncryptData(bytMessage, bytPassword)
Dim bytKey(31)
Dim bytIn()
Dim bytOut()
Dim bytTemp(31)
Dim lCount
Dim lLength
Dim lEncodedLength
Dim bytLen(3)
Dim lPosition
If Not IsInitialized(bytMessage) Then
Exit Function
End If
If Not IsInitialized(bytPassword) Then
Exit Function
End If
For lCount = 0 To UBound(bytPassword)
bytKey(lCount) = bytPassword(lCount)
If lCount = 31 Then
Exit For
End If
Next
gentables
gkey 8, 8, bytKey
lLength = UBound(bytMessage) + 1
lEncodedLength = lLength + 4
If lEncodedLength Mod 32 <> 0 Then
lEncodedLength = lEncodedLength + 32 - (lEncodedLength Mod 32)
End If
ReDim bytIn(lEncodedLength - 1)
ReDim bytOut(lEncodedLength - 1)
Unpack lLength, bytIn
CopyBytesASP bytIn, 4, bytMessage, 0, lLength
For lCount = 0 To lEncodedLength - 1 Step 32
CopyBytesASP bytTemp, 0, bytIn, lCount, 32
Encrypt bytTemp
CopyBytesASP bytOut, lCount, bytTemp, 0, 32
Next
EncryptData = bytOut
End Function
Public Function DecryptData(bytIn, bytPassword)
Dim bytMessage()
Dim bytKey(31)
Dim bytOut()
Dim bytTemp(31)
Dim lCount
Dim lLength
Dim lEncodedLength
Dim bytLen(3)
Dim lPosition
If Not IsInitialized(bytIn) Then
Exit Function
End If
If Not IsInitialized(bytPassword) Then
Exit Function
End If
lEncodedLength = UBound(bytIn) + 1
If lEncodedLength Mod 32 <> 0 Then
Exit Function
End If
For lCount = 0 To UBound(bytPassword)
bytKey(lCount) = bytPassword(lCount)
If lCount = 31 Then
Exit For
End If
Next
gentables
gkey 8, 8, bytKey
ReDim bytOut(lEncodedLength - 1)
For lCount = 0 To lEncodedLength - 1 Step 32
CopyBytesASP bytTemp, 0, bytIn, lCount, 32
Decrypt bytTemp
CopyBytesASP bytOut, lCount, bytTemp, 0, 32
Next
lLength = Pack(bytOut)
If lLength > lEncodedLength - 4 Then
Exit Function
End If
ReDim bytMessage(lLength - 1)
CopyBytesASP bytMessage, 0, bytOut, 4, lLength
DecryptData = bytMessage
End Function
8.一個(gè)日期轉(zhuǎn)換函數(shù)
Function FormatDate(byVal strDate, byVal strFormat)
' Accepts strDate as a valid date/time,
' strFormat as the output template.
' The function finds each item in the
' template and replaces it with the
' relevant information extracted from strDate.
' You are free to use this code provided the following line remains
' www.adopenstatic.com/resources/code/formatdate.asp
' Template items
' %m Month as a decimal no. 2
' %M Month as a padded decimal no. 02
' %B Full month name February
' %b Abbreviated month name Feb
' %d Day of the month eg 23
' %D Padded day of the month eg 09
' %O ordinal of day of month (eg st or rd or nd)
' %j Day of the year 54
' %Y Year with century 1998
' %y Year without century 98
' %w Weekday as integer (0 is Sunday)
' %a Abbreviated day name Fri
' %A Weekday Name Friday
' %H Hour in 24 hour format 24
' %h Hour in 12 hour format 12
' %N Minute as an integer 01
' %n Minute as optional if minute <> 00
' %S Second as an integer 55
' %P AM/PM Indicator PM
On Error Resume Next
Dim intPosItem
Dim int12HourPart
Dim str24HourPart
Dim strMinutePart
Dim strSecondPart
Dim strAMPM
' Insert Month Numbers
strFormat = Replace(strFormat, "%m", DatePart("m", strDate), 1, -1, vbBinaryCompare)
' Insert Padded Month Numbers
strFormat = Replace(strFormat, "%M", Right("0" & DatePart("m", strDate), 2), 1, -1, vbBinaryCompare)
' Insert non-Abbreviated Month Names
strFormat = Replace(strFormat, "%B", MonthName(DatePart("m", strDate), False), 1, -1, vbBinaryCompare)
' Insert Abbreviated Month Names
strFormat = Replace(strFormat, "%b", MonthName(DatePart("m", strDate), True), 1, -1, vbBinaryCompare)
' Insert Day Of Month
strFormat = Replace(strFormat, "%d", DatePart("d", strDate), 1, -1, vbBinaryCompare)
' Insert Padded Day Of Month
strFormat = Replace(strFormat, "%D", Right ("0" & DatePart("d", strDate), 2), 1, -1, vbBinaryCompare)
' Insert Day of Month ordinal (eg st, th, or rd)
strFormat = Replace(strFormat, "%O", GetDayOrdinal(Day(strDate)), 1, -1, vbBinaryCompare)
' Insert Day of Year
strFormat = Replace(strFormat, "%j", DatePart("y", strDate), 1, -1, vbBinaryCompare)
' Insert Long Year (4 digit)
strFormat = Replace(strFormat, "%Y", DatePart("yyyy", strDate), 1, -1, vbBinaryCompare)
' Insert Short Year (2 digit)
strFormat = Replace(strFormat, "%y", Right(DatePart("yyyy", strDate), 2), 1, -1, vbBinaryCompare)
' Insert Weekday as Integer (eg 0 = Sunday)
strFormat = Replace(strFormat, "%w", DatePart("w", strDate, 1), 1, -1, vbBinaryCompare)
' Insert Abbreviated Weekday Name (eg Sun)
strFormat = Replace(strFormat, "%a", WeekdayName(DatePart("w", strDate, 1), True), 1, -1, vbBinaryCompare)
' Insert non-Abbreviated Weekday Name
strFormat = Replace(strFormat, "%A", WeekdayName(DatePart("w", strDate, 1), False), 1, -1, vbBinaryCompare)
' Insert Hour in 24hr format
str24HourPart = DatePart("h", strDate)
If Len(str24HourPart) < 2 Then str24HourPart = "0" & str24HourPart
strFormat = Replace(strFormat, "%H", str24HourPart, 1, -1, vbBinaryCompare)
' Insert Hour in 12hr format
int12HourPart = DatePart("h", strDate) Mod 12
If int12HourPart = 0 Then int12HourPart = 12
strFormat = Replace(strFormat, "%h", int12HourPart, 1, -1, vbBinaryCompare)
' Insert Minutes
strMinutePart = DatePart("n", strDate)
If Len(strMinutePart) < 2 Then strMinutePart = "0" & strMinutePart
strFormat = Replace(strFormat, "%N", strMinutePart, 1, -1, vbBinaryCompare)
' Insert Optional Minutes
If CInt(strMinutePart) = 0 Then
strFormat = Replace(strFormat, "%n", "", 1, -1, vbBinaryCompare)
Else
If CInt(strMinutePart) < 10 Then strMinutePart = "0" & strMinutePart
strMinutePart = ":" & strMinutePart
strFormat = Replace(strFormat, "%n", strMinutePart, 1, -1, vbBinaryCompare)
End If
' Insert Seconds
strSecondPart = DatePart("s", strDate)
If Len(strSecondPart) < 2 Then strSecondPart = "0" & strSecondPart
strFormat = Replace(strFormat, "%S", strSecondPart, 1, -1, vbBinaryCompare)
' Insert AM/PM indicator
If DatePart("h", strDate) >= 12 Then
strAMPM = "PM"
Else
strAMPM = "AM"
End If
strFormat = Replace(strFormat, "%P", strAMPM, 1, -1, vbBinaryCompare)
FormatDate = strFormat
End Function
Function GetDayOrdinal( _
byVal intDay _
)
' Accepts a day of the month
' as an integer and returns the
' appropriate suffix
On Error Resume Next
Dim strOrd
Select Case intDay
Case 1, 21, 31
strOrd = "st"
Case 2, 22
strOrd = "nd"
Case 3, 23
strOrd = "rd"
Case Else
strOrd = "th"
End Select
GetDayOrdinal = strOrd
End Function
%>
<%
Dim db
db = "dbms.mdb"
'******************************************************************
'執(zhí)行sql語(yǔ)句，不返回值,sql語(yǔ)句最好是如下：
'update 表名 set 字段名=value,字段名=value where 字段名=value
'delete from 表名 where 字段名=value
'insert into 表名 (字段名,字段名) values (value,value)
'******************************************************************
Sub NoResult(sql)
Dim conn
Dim connstr
Set conn = Server.CreateObject("ADODB.Connection")
connstr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Server.MapPath(""&db&"")
conn.Open connstr
conn.Execute sql
conn.Close
Set conn = Nothing
End Sub
'*******************************************************************
'執(zhí)行select語(yǔ)句，返回recordset對(duì)象。該對(duì)象只讀。也就是不能更新
'*******************************************************************
Function Result(sql)
Dim conn
Dim connstr
Dim rcs
Set conn = Server.CreateObject("ADODB.Connection")
connstr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Server.MapPath(""&db&"")
conn.Open connstr
Set rcs = Server.CreateObject("ADODB.Recordset")
rcs.Open sql, conn, 1, 1
Set Result = rcs
End Function
'*******************************************************************
' 彈出對(duì)話框
'*******************************************************************
Sub alert(message)
message = Replace(message, "'", "\'")
Response.Write ("<script>alert('" & message & "')</script>")
End Sub
'*******************************************************************
' 返回上一頁(yè)，一般用在判斷信息提交是否完全之后
'*******************************************************************
Sub GoBack()
Response.Write ("<script>history.go(-1)</script>")
End Sub
'*******************************************************************
' 重定向另外的連接
'*******************************************************************
Sub Go(url)
Response.Write ("<script>location.href('" & url & "')</script>")
End Sub
'*******************************************************************
' 把html標(biāo)記替換
'*******************************************************************
Function htmlencode2(Str)
Dim result
Dim l
If IsNull(Str) Then
htmlencode2 = ""
Exit Function
End If
l = Len(Str)
result = ""
Dim i
For i = 1 To l
Select Case Mid(Str, i, 1)
Case "<"
result = result + "<"
Case ">"
result = result + ">"
Case Chr(13)
result = result + "<br>"
Case Chr(34)
result = result + """%>
<%
cLeft(String, Length) 返回指定數(shù)目的從字符串的左邊算起的字符，區(qū)分單雙字節(jié)。
如：
Dim MyString, LeftString
MyString = "文字測(cè)試VBSCript"
LeftString = cLeft(MyString, 10)
返回 "文字測(cè)試VB"。
MyRandc(n) 生成隨機(jī)字符，n為字符的個(gè)數(shù)
如：
response.Write MyRandn(10)
輸出10個(gè)隨機(jī)字符
MyRandn(n) 生成隨機(jī)數(shù)字，n為數(shù)字的個(gè)數(shù)
如：
response.Write MyRandn(10)
輸出10個(gè)隨機(jī)數(shù)字
formatQueryStr(Str) 格式化sql中的like字符串.
如：
q = Request("q")
q = formatQueryStr(q)
sql = "select * from [table] where aa like '%"& q &"%'"
GetRnd(min, max) 返回min - max之間的一個(gè)隨機(jī)數(shù)
如：
response.Write GetRnd(100, 200)
輸出大于100到200之間的一個(gè)隨機(jī)數(shù)
Function cLeft(Str, n)
Dim str1, str2, alln, Islefted
str2 = ""
alln = 0
str1 = Str
Islefted = False
If IsNull(Str) Then
cleft = ""
Exit Function
End If
For i = 1 To Len(str1)
nowstr = Mid(str1, i, 1)
If Asc(nowstr)<0 Then
alln = alln + 2
Else
alln = alln + 1
End If
If (alln<= n) Then
str2 = str2 & nowstr
Else
Islefted = True
Exit For
End If
Next
If Islefted Then
str2 = str2 & ".."
End If
cleft = str2
End Function
Function MyRandc(n) '生成隨機(jī)字符，n為字符的個(gè)數(shù)
Dim thechr
thechr = ""
For i = 1 To n
Dim zNum, zNum2
Randomize
zNum = CInt(25 * Rnd)
zNum2 = CInt(10 * Rnd)
If zNum2 Mod 2 = 0 Then
zNum = zNum + 97
Else
zNum = zNum + 65
End If
thechr = thechr & Chr(zNum)
Next
MyRandc = thechr
End Function
Function MyRandn(n) '生成隨機(jī)數(shù)字，n為數(shù)字的個(gè)數(shù)
Dim thechr
thechr = ""
For i = 1 To n
Dim zNum, zNum2
Randomize
zNum = CInt(9 * Rnd)
zNum = zNum + 48
thechr = thechr & Chr(zNum)
Next
MyRandn = thechr
End Function
Function formatQueryStr(Str) '格式化sql中的like字符串
Dim nstr
nstr = Str
nstr = Replace(nstr, Chr(0), "")
nstr = Replace(nstr, "'", "''")
nstr = Replace(nstr, "[", "[[]")
nstr = Replace(nstr, "%", "[%]")
formatQueryStr = nstr
End Function
Function GetRnd(min, max)
Randomize
GetRnd = Int((max - min + 1) * Rnd + min)
End Function
'*******************************************************************
'取得IP地址
'*******************************************************************
Function Userip()
Dim GetClientIP
'如果客戶端用了代理服務(wù)器，則應(yīng)該用ServerVariables("HTTP_X_FORWARDED_FOR")方法
GetClientIP = Request.ServerVariables("HTTP_X_FORWARDED_FOR")
If GetClientIP = "" or IsNull(GetClientIP) or IsEmpty(GetClientIP) Then
'如果客戶端沒用代理，應(yīng)該用Request.ServerVariables("REMOTE_ADDR")方法
GetClientIP = Request.ServerVariables("REMOTE_ADDR")
End If
Userip = GetClientIP
End Function
'*******************************************************************
'轉(zhuǎn)換IP地址
'*******************************************************************
Function cip(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)
End Function
'*******************************************************************
' 彈出對(duì)話框
'*******************************************************************
Sub alert(message)
message = Replace(message, "'", "\'")
Response.Write ("<script>alert('" & message & "')</script>")
End Sub
'*******************************************************************
' 返回上一頁(yè)，一般用在判斷信息提交是否完全之后
'*******************************************************************
Sub GoBack()
Response.Write ("<script>history.go(-1)</script>")
End Sub
'*******************************************************************
' 重定向另外的連接
'*******************************************************************
Sub Go(url)
Response.Write ("<script>location.href('" & url & "')</script>")
End Sub
'*******************************************************************
' 指定秒數(shù)重定向另外的連接
'*******************************************************************
Sub GoPage(url, s)
s = s * 1000
Response.Write "<SCRIPT LANGUAGE=javascript>"
Response.Write "window.setTimeout("&Chr(34)&"window.navigate('"&url&"')"&Chr(34)&","&s&")"
Response.Write "</script>"
End Sub
'*******************************************************************
' 判斷數(shù)字是否整形
'*******************************************************************
Function isInteger(para)
On Error Resume Next
Dim Str
Dim l, i
If IsNull(para) Then
isInteger = False
Exit Function
End If
Str = CStr(para)
If Trim(Str) = "" Then
isInteger = False
Exit Function
End If
l = Len(Str)
For i = 1 To l
If Mid(Str, i, 1)>"9" or Mid(Str, i, 1)<"0" Then
isInteger = False
Exit Function
End If
Next
isInteger = True
If Err.Number<>0 Then Err.Clear
End Function
'*******************************************************************
' 獲得文件擴(kuò)展名
'*******************************************************************
Function GetExtend(filename)
Dim tmp
If filename<>"" Then
tmp = Mid(filename, instrrev(filename, ".") + 1, Len(filename) - instrrev(filename, "."))
tmp = LCase(tmp)
If InStr(1, tmp, "asp")>0 or InStr(1, tmp, "php")>0 or InStr(1, tmp, "php3")>0 or InStr(1, tmp, "aspx")>0 Then
getextend = "txt"
Else
getextend = tmp
End If
Else
getextend = ""
End If
End Function
' *----------------------------------------------------------------------------
' * 函數(shù)：CheckIn
' * 描述：檢測(cè)參數(shù)是否有SQL危險(xiǎn)字符
' * 參數(shù)：str要檢測(cè)的數(shù)據(jù)
' * 返回：FALSE：安全 TRUE：不安全
' * 作者：
' * 日期：
' *----------------------------------------------------------------------------
Function CheckIn(Str)
If InStr(1, Str, Chr(39))>0 or InStr(1, Str, Chr(34))>0 or InStr(1, Str, Chr(59))>0 Then
CheckIn = True
Else
CheckIn = False
End If
End Function
' *----------------------------------------------------------------------------
' * 函數(shù)：HTMLEncode
' * 描述：過(guò)濾HTML代碼
' * 參數(shù)：--
' * 返回：--
' * 作者：
' * 日期：
' *----------------------------------------------------------------------------
Function HTMLEncode(fString)
If Not IsNull(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
End If
End Function
' *----------------------------------------------------------------------------
' * 函數(shù)：HTMLcode
' * 描述：過(guò)濾表單字符
' * 參數(shù)：--
' * 返回：--
' * 作者：
' * 日期：
' *----------------------------------------------------------------------------
Function HTMLcode(fString)
If Not IsNull(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
End If
End Function
%>
<%
cLeft(String, Length) 返回指定數(shù)目的從字符串的左邊算起的字符，區(qū)分單雙字節(jié)。
如：
Dim MyString, LeftString
MyString = "文字測(cè)試VBSCript"
LeftString = cLeft(MyString, 10)
返回 "文字測(cè)試VB"。
MyRandc(n) 生成隨機(jī)字符，n為字符的個(gè)數(shù)
如：
response.Write MyRandn(10)
輸出10個(gè)隨機(jī)字符
MyRandn(n) 生成隨機(jī)數(shù)字，n為數(shù)字的個(gè)數(shù)
如：
response.Write MyRandn(10)
輸出10個(gè)隨機(jī)數(shù)字
formatQueryStr(Str) 格式化sql中的like字符串.
如：
q = Request("q")
q = formatQueryStr(q)
sql = "select * from [table] where aa like '%"& q &"%'"
GetRnd(min, max) 返回min - max之間的一個(gè)隨機(jī)數(shù)
如：
response.Write GetRnd(100, 200)
輸出大于100到200之間的一個(gè)隨機(jī)數(shù)
Function cLeft(Str, n)
Dim str1, str2, alln, Islefted
str2 = ""
alln = 0
str1 = Str
Islefted = False
If IsNull(Str) Then
cleft = ""
Exit Function
End If
For i = 1 To Len(str1)
nowstr = Mid(str1, i, 1)
If Asc(nowstr)<0 Then
alln = alln + 2
Else
alln = alln + 1
End If
If (alln<= n) Then
str2 = str2 & nowstr
Else
Islefted = True
Exit For
End If
Next
If Islefted Then
str2 = str2 & ".."
End If
cleft = str2
End Function
Function MyRandc(n) '生成隨機(jī)字符，n為字符的個(gè)數(shù)
Dim thechr
thechr = ""
For i = 1 To n
Dim zNum, zNum2
Randomize
zNum = CInt(25 * Rnd)
zNum2 = CInt(10 * Rnd)
If zNum2 Mod 2 = 0 Then
zNum = zNum + 97
Else
zNum = zNum + 65
End If
thechr = thechr & Chr(zNum)
Next
MyRandc = thechr
End Function
Function MyRandn(n) '生成隨機(jī)數(shù)字，n為數(shù)字的個(gè)數(shù)
Dim thechr
thechr = ""
For i = 1 To n
Dim zNum, zNum2
Randomize
zNum = CInt(9 * Rnd)
zNum = zNum + 48
thechr = thechr & Chr(zNum)
Next
MyRandn = thechr
End Function
Function formatQueryStr(Str) '格式化sql中的like字符串
Dim nstr
nstr = Str
nstr = Replace(nstr, Chr(0), "")
nstr = Replace(nstr, "'", "''")
nstr = Replace(nstr, "[", "[[]")
nstr = Replace(nstr, "%", "[%]")
formatQueryStr = nstr
End Function
Function GetRnd(min, max)
Randomize
GetRnd = Int((max - min + 1) * Rnd + min)
End Function
'*******************************************************************
'取得IP地址
'*******************************************************************
Function Userip()
Dim GetClientIP
'如果客戶端用了代理服務(wù)器，則應(yīng)該用ServerVariables("HTTP_X_FORWARDED_FOR")方法
GetClientIP = Request.ServerVariables("HTTP_X_FORWARDED_FOR")
If GetClientIP = "" or IsNull(GetClientIP) or IsEmpty(GetClientIP) Then
'如果客戶端沒用代理，應(yīng)該用Request.ServerVariables("REMOTE_ADDR")方法
GetClientIP = Request.ServerVariables("REMOTE_ADDR")
End If
Userip = GetClientIP
End Function
'*******************************************************************
'轉(zhuǎn)換IP地址
'*******************************************************************
Function cip(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)
End Function
'*******************************************************************
' 彈出對(duì)話框
'*******************************************************************
Sub alert(message)
message = Replace(message, "'", "\'")
Response.Write ("<script>alert('" & message & "')</script>")
End Sub
'*******************************************************************
' 返回上一頁(yè)，一般用在判斷信息提交是否完全之后
'*******************************************************************
Sub GoBack()
Response.Write ("<script>history.go(-1)</script>")
End Sub
'*******************************************************************
' 重定向另外的連接
'*******************************************************************
Sub Go(url)
Response.Write ("<script>location.href('" & url & "')</script>")
End Sub
'*******************************************************************
' 指定秒數(shù)重定向另外的連接
'*******************************************************************
Sub GoPage(url, s)
s = s * 1000
Response.Write "<SCRIPT LANGUAGE=javascript>"
Response.Write "window.setTimeout("&Chr(34)&"window.navigate('"&url&"')"&Chr(34)&","&s&")"
Response.Write "</script>"
End Sub
'*******************************************************************
' 判斷數(shù)字是否整形
'*******************************************************************
Function isInteger(para)
On Error Resume Next
Dim Str
Dim l, i
If IsNull(para) Then
isInteger = False
Exit Function
End If
Str = CStr(para)
If Trim(Str) = "" Then
isInteger = False
Exit Function
End If
l = Len(Str)
For i = 1 To l
If Mid(Str, i, 1)>"9" or Mid(Str, i, 1)<"0" Then
isInteger = False
Exit Function
End If
Next
isInteger = True
If Err.Number<>0 Then Err.Clear
End Function
'*******************************************************************
' 獲得文件擴(kuò)展名
'*******************************************************************
Function GetExtend(filename)
Dim tmp
If filename<>"" Then
tmp = Mid(filename, instrrev(filename, ".") + 1, Len(filename) - instrrev(filename, "."))
tmp = LCase(tmp)
If InStr(1, tmp, "asp")>0 or InStr(1, tmp, "php")>0 or InStr(1, tmp, "php3")>0 or InStr(1, tmp, "aspx")>0 Then
getextend = "txt"
Else
getextend = tmp
End If
Else
getextend = ""
End If
End Function
' *----------------------------------------------------------------------------
' * 函數(shù)：CheckIn
' * 描述：檢測(cè)參數(shù)是否有SQL危險(xiǎn)字符
' * 參數(shù)：str要檢測(cè)的數(shù)據(jù)
' * 返回：FALSE：安全 TRUE：不安全
' * 作者：
' * 日期：
' *----------------------------------------------------------------------------
Function CheckIn(Str)
If InStr(1, Str, Chr(39))>0 or InStr(1, Str, Chr(34))>0 or InStr(1, Str, Chr(59))>0 Then
CheckIn = True
Else
CheckIn = False
End If
End Function
' *----------------------------------------------------------------------------
' * 函數(shù)：HTMLEncode
' * 描述：過(guò)濾HTML代碼
' * 參數(shù)：--
' * 返回：--
' * 作者：
' * 日期：
' *----------------------------------------------------------------------------
Function HTMLEncode(fString)
If Not IsNull(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
End If
End Function
' *----------------------------------------------------------------------------
' * 函數(shù)：HTMLcode
' * 描述：過(guò)濾表單字符
' * 參數(shù)：--
' * 返回：--
' * 作者：
' * 日期：
' *----------------------------------------------------------------------------
Function HTMLcode(fString)
If Not IsNull(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
End If
End Function
%>
11.ACCESS數(shù)據(jù)庫(kù)連接:
<%
Option Explicit
Dim startime, endtime, conn, connstr, db
startime = Timer()
'更改數(shù)據(jù)庫(kù)名字
db = "data/dvBBS5.mdb"
Set conn = Server.CreateObject("ADODB.Connection")
connstr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Server.MapPath(db)
'如果你的服務(wù)器采用較老版本Access驅(qū)動(dòng)，請(qǐng)用下面連接方法
'connstr="driver={Microsoft Access Driver (*.mdb)};dbq=" & Server.MapPath(db)
conn.Open connstr
Function CloseDatabase
Conn.Close
Set conn = Nothing
End Function
%>
12.SQL數(shù)據(jù)庫(kù)連接:
<%
Option Explicit
Dim startime, endtime, conn, connstr, db
startime = Timer()
connstr = "driver={SQL Server};server=HUDENQ-N11T33NB;uid=sa;pwd=xsfeihu;database=dvbbs"
Set conn = Server.CreateObject("ADODB.Connection")
conn.Open connstr
Function CloseDatabase
Conn.Close
Set conn = Nothing
End Function
%>
13.用鍵盤打開網(wǎng)頁(yè)代碼:
<script language="javascript">
function ctlent(eventobject)
{
if((event.ctrlKey && window.event.keyCode==13)||(event.altKey && window.event.keyCode==83))
{
window.open('網(wǎng)址','','')
}
}
</script>
這里是Ctrl+Enter和Alt+S的代碼 自己查下鍵盤的ASCII碼再換就行
14.讓層不被控件復(fù)蓋代碼:
<div z-Index:2><object ***></object></div> ＃ 前面
<div z-Index:1><object ***></object></div> ＃ 后面
<div id="Layer2" style="position:absolute; top:40;width:400px; height:95px;z-index:2"><table height=100% width=100% bgcolor="#ff0000"><tr><td height=100% width=100%></td></tr></table><iframe width=0 height=0></iframe></div>
<div id="Layer1" style="position:absolute; top:50;width:200px; height:115px;z-index:1"><iframe height=100% width=100%></iframe></div>
15.動(dòng)網(wǎng)FLASH廣告代碼:
<object classid="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"><param name=movie value="images/yj16d.swf"><param name=quality value=high><embed src="images/dvbanner.swf" quality=high pluginspage="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彈出窗口小代碼:
<script language=vbscript>
msgbox"你還沒有注冊(cè)或登陸論壇","0","精品論壇"
location.href = "login.asp"
</script>
16.使用FSO修改文件特定內(nèi)容的函數(shù)
<%
Function FSOchange(filename, Target, String)
Dim objFSO, objCountFile, FiletempData
Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
Set objCountFile = objFSO.OpenTextFile(Server.MapPath(filename), 1, True)
FiletempData = objCountFile.ReadAll
objCountFile.Close
FiletempData = Replace(FiletempData, Target, String)
Set objCountFile = objFSO.CreateTextFile(Server.MapPath(filename), True)
objCountFile.Write FiletempData
objCountFile.Close
Set objCountFile = Nothing
Set objFSO = Nothing
End Function
%>
17.使用FSO讀取文件內(nèi)容的函數(shù)
<%
Function FSOFileRead(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
%>
18.使用FSO讀取文件某一行的函數(shù)
<%
Function FSOlinedit(filename, lineNum)
If linenum < 1 Then Exit Function
Dim fso, f, temparray, tempcnt
Set fso = server.CreateObject("scripting.filesystemobject")
If Not fso.FileExists(server.mappath(filename)) Then Exit Function
Set f = fso.OpenTextFile(server.mappath(filename), 1)
If Not f.AtEndOfStream Then
tempcnt = f.ReadAll
f.Close
Set f = Nothing
temparray = Split(tempcnt, Chr(13)&Chr(10))
If lineNum>UBound(temparray) + 1 Then
Exit Function
Else
FSOlinedit = temparray(lineNum -1)
End If
End If
End Function
%>
19.使用FSO寫文件某一行的函數(shù)
<%
Function FSOlinewrite(filename, lineNum, Linecontent)
If linenum < 1 Then Exit Function
Dim fso, f, temparray, tempCnt
Set fso = server.CreateObject("scripting.filesystemobject")
If Not fso.FileExists(server.mappath(filename)) Then Exit Function
Set f = fso.OpenTextFile(server.mappath(filename), 1)
If Not f.AtEndOfStream Then
tempcnt = f.ReadAll
f.Close
temparray = Split(tempcnt, Chr(13)&Chr(10))
If lineNum>UBound(temparray) + 1 Then
Exit Function
Else
temparray(lineNum -1) = lineContent
End If
tempcnt = Join(temparray, Chr(13)&Chr(10))
Set f = fso.CreateTextFile(server.mappath(filename), True)
f.Write tempcnt
End If
f.Close
Set f = Nothing
End Function
%>
20.使用FSO添加文件新行的函數(shù)
<%
Function FSOappline(filename, Linecontent)
Dim fso, f
Set fso = server.CreateObject("scripting.filesystemobject")
If Not fso.FileExists(server.mappath(filename)) Then Exit Function
Set f = fso.OpenTextFile(server.mappath(filename), 8, 1)
f.Write Chr(13)&Chr(10)&Linecontent
f.Close
Set f = Nothing
End Function
%>
21.讀文件最后一行的函數(shù)
<%
Function FSOlastline(filename)
Dim fso, f, temparray, tempcnt
Set fso = server.CreateObject("scripting.filesystemobject")
If Not fso.FileExists(server.mappath(filename)) Then Exit Function
Set f = fso.OpenTextFile(server.mappath(filename), 1)
If Not f.AtEndOfStream Then
tempcnt = f.ReadAll
f.Close
Set f = Nothing
temparray = Split(tempcnt, Chr(13)&Chr(10))
FSOlastline = temparray(UBound(temparray))
End If
End Function
%>
利用FSO取得BMP，JPG，PNG，GIF文件信息(大小，寬、高等)
<%
'::: BMP, GIF, JPG and PNG :::
'::: This function gets a specified number of bytes from any :::
'::: file, starting at the offset (base 1) :::
'::: :::
'::: Passed: :::
'::: flnm => Filespec of file to read :::
'::: offset => Offset at which to start reading :::
'::: bytes => How many bytes to read :::
'::: :::
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
Function GetBytes(flnm, offset, bytes)
Dim objFSO
Dim objFTemp
Dim objTextStream
Dim lngSize
On Error Resume Next
Set objFSO = CreateObject("Scripting.FileSystemObject")
' First, we get the filesize
Set objFTemp = objFSO.GetFile(flnm)
lngSize = objFTemp.Size
Set objFTemp = Nothing
fsoForReading = 1
Set objTextStream = objFSO.OpenTextFile(flnm, fsoForReading)
If offset > 0 Then
strBuff = objTextStream.Read(offset - 1)
End If
If bytes = -1 Then ' Get All!
GetBytes = objTextStream.Read(lngSize) 'ReadAll
Else
GetBytes = objTextStream.Read(bytes)
End If
objTextStream.Close
Set objTextStream = Nothing
Set objFSO = Nothing
End Function
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
'::: :::
'::: Functions to convert two bytes to a numeric value (long) :::
'::: (both little-endian and big-endian) :::
'::: :::
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
Function lngConvert(strTemp)
lngConvert = CLng(Asc(Left(strTemp, 1)) + ((Asc(Right(strTemp, 1)) * 256)))
End Function
Function lngConvert2(strTemp)
lngConvert2 = CLng(Asc(Right(strTemp, 1)) + ((Asc(Left(strTemp, 1)) * 256)))
End Function
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
'::: :::
'::: This function does most of the real work. It will attempt :::
'::: to read any file, regardless of the extension, and will :::
'::: identify if it is a graphical image. :::
'::: :::
'::: Passed: :::
'::: flnm => Filespec of file to read :::
'::: width => width of image :::
'::: height => height of image :::
'::: depth => color depth (in number of colors) :::
'::: strImageType=> type of image (e.g. GIF, BMP, etc.) :::
'::: :::
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
Function gfxSpex(flnm, Width, height, depth, strImageType)
Dim strPNG
Dim strGIF
Dim strBMP
Dim strType
strType = ""
strImageType = "(unknown)"
gfxSpex = False
strPNG = Chr(137) & Chr(80) & Chr(78)
strGIF = "GIF"
strBMP = Chr(66) & Chr(77)
strType = GetBytes(flnm, 0, 3)
If strType = strGIF Then ' is GIF
strImageType = "GIF"
Width = lngConvert(GetBytes(flnm, 7, 2))
Height = lngConvert(GetBytes(flnm, 9, 2))
Depth = 2 ^ ((Asc(GetBytes(flnm, 11, 1)) And 7) + 1)
gfxSpex = True
ElseIf Left(strType, 2) = strBMP Then ' is BMP
strImageType = "BMP"
Width = lngConvert(GetBytes(flnm, 19, 2))
Height = lngConvert(GetBytes(flnm, 23, 2))
Depth = 2 ^ (Asc(GetBytes(flnm, 29, 1)))
gfxSpex = True
ElseIf strType = strPNG Then ' Is PNG
strImageType = "PNG"
Width = lngConvert2(GetBytes(flnm, 19, 2))
Height = lngConvert2(GetBytes(flnm, 23, 2))
Depth = getBytes(flnm, 25, 2)
Select Case Asc(Right(Depth, 1))
Case 0
Depth = 2 ^ (Asc(Left(Depth, 1)))
gfxSpex = True
Case 2
Depth = 2 ^ (Asc(Left(Depth, 1)) * 3)
gfxSpex = True
Case 3
Depth = 2 ^ (Asc(Left(Depth, 1))) '8
gfxSpex = True
Case 4
Depth = 2 ^ (Asc(Left(Depth, 1)) * 2)
gfxSpex = True
Case 6
Depth = 2 ^ (Asc(Left(Depth, 1)) * 4)
gfxSpex = True
Case Else
Depth = -1
End Select
Else
strBuff = GetBytes(flnm, 0, -1) ' Get all bytes from file
lngSize = Len(strBuff)
flgFound = 0
strTarget = Chr(255) & Chr(216) & Chr(255)
flgFound = InStr(strBuff, strTarget)
If flgFound = 0 Then
Exit Function
End If
strImageType = "JPG"
lngPos = flgFound + 2
ExitLoop = False
Do While ExitLoop = False And lngPos < lngSize
Do While Asc(Mid(strBuff, lngPos, 1)) = 255 And lngPos < lngSize
lngPos = lngPos + 1
Loop
If Asc(Mid(strBuff, lngPos, 1)) < 192 or Asc(Mid(strBuff, lngPos, 1)) > 195 Then
lngMarkerSize = lngConvert2(Mid(strBuff, lngPos + 1, 2))
lngPos = lngPos + lngMarkerSize + 1
Else
ExitLoop = True
End If
Loop
'
If ExitLoop = False Then
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
End If
End If
End Function
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
'::: Test Harness :::
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
' To test, we'll just try to show all files with a .GIF extension in the root of C:
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objF = objFSO.GetFolder("c:\")
Set objFC = objF.Files
response.Write "<table border=""0"" cellpadding=""5"">"
For Each f1 in objFC
If InStr(UCase(f1.Name), ".GIF") Then
response.Write "<tr><td>" & f1.Name & "</td><td>" & f1.DateCreated & "</td><td>" & f1.Size & "</td><td>"
If gfxSpex(f1.Path, w, h, c, strType) = True Then
response.Write w & " x " & h & " " & c & " colors"
Else
response.Write " "
End If
response.Write "</td></tr>"
End If
Next
response.Write "</table>"
Set objFC = Nothing
Set objF = Nothing
Set objFSO = Nothing
%>
24.點(diǎn)擊返回上頁(yè)代碼:
<form>
<p><input TYPE="button" value="返回上一步" onCLICK="history.back(-1)"></p>
</form>
24.點(diǎn)擊刷新代碼:
<form>
<p><input TYPE="button" value="刷新按鈕一" onCLICK="ReloadButton()"></p>
</form>
<script language="javascript"><!--
function ReloadButton(){location.href="allbutton.htm";}
// --></script>
24.點(diǎn)擊刷新代碼2:
<form>
<p><input TYPE="button" value="刷新按鈕二" onClick="history.go(0)"> </p>
</form>
<form>
<p><input TYPE="button" value="打開一個(gè)網(wǎng)站" onCLICK="HomeButton()"></p>
</form>
<script language="javascript"><!--
function HomeButton(){location.;;;}
// --></script>
25.彈出警告框代碼:
<form>
<p><input TYPE="button" value="彈出警告框" onCLICK="AlertButton()"></p>
</form>
<script language="javascript"><!--
function AlertButton(){window.alert("要多多光臨呀！");}
// --></script>
26.狀態(tài)欄信息
<form>
<p><input TYPE="button" value="狀態(tài)欄信息" onCLICK="StatusButton()"></p>
</form>
<script language="javascript"><!--
function StatusButton(){window.status="要多多光臨呀！";}
// --></script>
27.背景色變換
<form>
<p><input TYPE="button" value="背景色變換" onClick="BgButton()"></p>
</form>
<script>function BgButton(){
if (document.bgColor=='#00ffff')
{document.bgColor='#ffffff';}
else{document.bgColor='#00ffff';}
}
</script>
28.點(diǎn)擊打開新窗口
<form>
<p><input TYPE="button" value="打開新窗口" onCLICK="NewWindow()"></p>
</form>
<script language="javascript"><!--
function NewWindow(){window.open("http://www.mcmx.com";;,"","height=240,width=340,status=no,location=no,toolbar=no,directories=no,menubar=no");}
// --></script></body>
29.分頁(yè)代碼:
<%''本程序文件名為：Pages.asp%>
<%''包含ADO常量表文件adovbs.inc，可從"\Program Files\Common Files\System\ADO"目錄下拷貝%>
<!--#Include File="adovbs.inc"-->
<%''＊建立數(shù)據(jù)庫(kù)連接，這里是Oracle8.05數(shù)據(jù)庫(kù)
Set conn = Server.CreateObject("ADODB.Connection")
conn.Open "Provider=msdaora.1;Data Source=YourSrcName;User ID=YourUserID;Password=YourPassword;"
Set rs = Server.CreateObject("ADODB.Recordset") ''創(chuàng)建Recordset對(duì)象
rs.CursorLocation = adUseClient ''設(shè)定記錄集指針屬性
''＊設(shè)定一頁(yè)內(nèi)的記錄總數(shù)，可根據(jù)需要進(jìn)行調(diào)整
rs.PageSize = 10
''＊設(shè)置查詢語(yǔ)句
StrSQL = "Select ID,姓名,住址,電話 from 通訊錄 order By ID"
rs.Open StrSQL, conn, adOpenStatic, adLockReadOnly, adCmdText
%>
<HTML>
<HEAD>
<title>分頁(yè)示例</title>
<script language=javascript>
//點(diǎn)擊"[第一頁(yè)]"時(shí)響應(yīng)：
function PageFirst()
{
document.MyForm.CurrentPage.selectedIndex=0;
document.MyForm.CurrentPage.onchange();
}
//點(diǎn)擊"[上一頁(yè)]"時(shí)響應(yīng)：
function PagePrior()
{
document.MyForm.CurrentPage.selectedIndex--;
document.MyForm.CurrentPage.onchange();
}
//點(diǎn)擊"[下一頁(yè)]"時(shí)響應(yīng)：
function PageNext()
{
document.MyForm.CurrentPage.selectedIndex++;
document.MyForm.CurrentPage.onchange();
}
//點(diǎn)擊"[最后一頁(yè)]"時(shí)響應(yīng)：
function PageLast()
{
document.MyForm.CurrentPage.selectedIndex=document.MyForm.CurrentPage.length-1;
document.MyForm.CurrentPage.onchange();
}
//選擇"第？頁(yè)"時(shí)響應(yīng)：
function PageCurrent()
{ //Pages.asp是本程序的文件名
document.MyForm.action='Pages.asp?Page='+(document.MyForm.CurrentPage.selectedIndex+1)
document.MyForm.submit();
}
</Script>
</HEAD>
<BODY bgcolor="#ffffcc" link="#008000" vlink="#008000" alink="#FF0000"">
<%
If rs.EOF Then
Response.Write("<font size=2 color=#000080>[數(shù)據(jù)庫(kù)中沒有記錄！]</font>")
Else
''指定當(dāng)前頁(yè)碼
If Request("CurrentPage") = "" Then
rs.AbsolutePage = 1
Else
rs.AbsolutePage = CLng(Request("CurrentPage"))
End If
''創(chuàng)建表單MyForm,方法為Get
Response.Write("<form method=Get name=MyForm>")
Response.Write("<p align=center><font size=2 color=#008000>")
''設(shè)置翻頁(yè)超鏈接
If rs.PageCount = 1 Then
Response.Write("[第一頁(yè)] [上一頁(yè)] [下一頁(yè)] [最后一頁(yè)] ")
Else
If rs.AbsolutePage = 1 Then
Response.Write("[第一頁(yè)] [上一頁(yè)] ")
Response.Write("[<a href=java script:PageNext()>下一頁(yè)</a>] ")
Response.Write("[<a href=java script:PageLast()>最后一頁(yè)</a>] ")
Else
If rs.AbsolutePage = rs.PageCount Then
Response.Write("[<a href=java script:PageFirst()>第一頁(yè)</a>] ")
Response.Write("[<a href=java script:PagePrior()>上一頁(yè)</a>] ")
Response.Write("[下一頁(yè)] [最后一頁(yè)] ")
Else
Response.Write("[<a href=java script:PageFirst()>第一頁(yè)</a>] ")
Response.Write("[<a href=java script:PagePrior()>上一頁(yè)</a>] ")
Response.Write("[<a href=java script:PageNext()>下一頁(yè)</a>] ")
Response.Write("[<a href=java script:PageLast()>最后一頁(yè)</a>] ")
End If
End If
End If
''創(chuàng)建下拉列表框，用于選擇瀏覽頁(yè)碼
Response.Write("第<select size=1 name=CurrentPage onchange=PageCurrent()>")
For i = 1 To rs.PageCount
If rs.AbsolutePage = i Then
Response.Write("<option selected>"&i&"</option>") ''當(dāng)前頁(yè)碼
Else
Response.Write("<option>"&i&"</option>")
End If
Next
Response.Write("</select>頁(yè)/共"&rs.PageCount&"頁(yè) 共"&rs.RecordCount&"條記錄</font><p>")
Response.Write("</form>")
''創(chuàng)建表格，用于顯示
Response.Write("<table align=center cellspacing=1 cellpadding=1 border=1")
Response.Write(" bordercolor=#99CCFF bordercolordark=#b0e0e6 bordercolorlight=#000066>")
Response.Write("<tr bgcolor=#ccccff bordercolor=#000066>")
Set Columns = rs.Fields
''顯示表頭
For i = 0 To Columns.Count -1
Response.Write("<td align=center width=200 height=13>")
Response.Write("<font size=2><b>"&Columns(i).Name&"</b></font></td>")
Next
Response.Write("</tr>")
''顯示內(nèi)容
For i = 1 To rs.PageSize
Response.Write("<tr bgcolor=#99ccff bordercolor=#000066>")
For j = 0 To Columns.Count -1
Response.Write("<td><font size=2>"&Columns(j)&"</font></td>")
Next
Response.Write("</tr>")
rs.movenext
If rs.EOF Then Exit For
Next
Response.Write("</table>")
End If
%>
</BODY>
</HTML>
<%
Rem - - - 表單提示函數(shù) Being - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
CODE Copy ...
Function Check_submit(Str, restr)
If Str = "" Then
response.Write "<script>"
response.Write "alert(‘'"&restr&"‘');"
response.Write "history.go(-1)"
response.Write "</script>"
response.End
Else
Check_submit = Str
End If
End Function
CODE Copy ...
Function Alert_submit(Str)
response.Write "<script>"
response.Write "alert(‘'"&Str&"‘');"
‘'response.Write "location.reload();"
response.Write "</script>"
End Function
CODE Copy ...
Function localhost_submit(Str, urls)
response.Write "<script>"
If Str<>"" Then
response.Write "alert(‘'"&Str&"‘');"
End If
response.Write "location=‘'"&urls&"‘';"
response.Write "</script>"
End Function
Rem - - - 生成自定義位隨機(jī)數(shù) Being - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
CODE Copy ...
Function makerndid(byVal maxLen)
Dim strNewPass
Dim whatsNext, upper, lower, intCounter
Randomize
For intCounter = 1 To maxLen
whatsNext = Int(2 * Rnd)
If whatsNext = 0 Then
upper = 80
lower = 70
Else
upper = 48
lower = 39
End If
strNewPass = strNewPass & Chr(Int((upper - lower + 1) * Rnd + upper))
Next
makerndid = strNewPass
End Function
Rem - - - 生成四位隨機(jī)數(shù) Being - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
CODE Copy ...
Function get_rand()
Dim num1
Dim rndnum
Randomize
Do While Len(rndnum)<4
num1 = CStr(Chr((57 -48) * Rnd + 48))
rndnum = rndnum&num1
Loop
get_rand = rndnum
End Function
Rem - - - 判斷數(shù)據(jù)是否整型 Being - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
CODE Copy ...
Function IsInteger(para)
On Error Resume Next
Dim Str
Dim l, i
If IsNull(para) Then
isInteger = False
Exit Function
End If
Str = CStr(para)
If Trim(Str) = "" Then
isInteger = False
Exit Function
End If
l = Len(Str)
For i = 1 To l
If Mid(Str, i, 1)>"9" or Mid(Str, i, 1)<"0" Then
isInteger = False
Exit Function
End If
Next
isInteger = True
If Err.Number<>0 Then Err.Clear
End Function
Rem - - - 數(shù)據(jù)庫(kù)鏈接函數(shù) Being - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
CODE Copy ...
Function OpenCONN
Set conn = Server.CreateObject("ADODB.Connection")
connstr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Server.MapPath(DB_login)
conn.Open connstr
End Function
Rem - - - 中文字符轉(zhuǎn)Uncode代碼函數(shù) Being - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
CODE Copy ...
Function URLEncoding(vstrIn)
strReturn = ""
For i = 1 To Len(vstrIn)
ThisChr = Mid(vStrIn, i, 1)
If Abs(Asc(ThisChr)) < &HFF Then
strReturn = strReturn & ThisChr
Else
innerCode = Asc(ThisChr)
If innerCode < 0 Then
innerCode = innerCode + &H10000
End If
Hight8 = (innerCode And &HFF00) \ &HFF
Low8 = innerCode And &HFF
strReturn = strReturn & "%" & Hex(Hight8) & "%" & Hex(Low8)
End If
Next
URLEncoding = strReturn
End Function
Rem - - - Html過(guò)濾函數(shù) Being - - - - - - - - - - - - - - - - - - - - - - - - - - - - - Function Htmlout(Str)
CODE Copy ...
Dim result
Dim l
If IsNull(Str) Then
Htmlout = ""
Exit Function
End If
l = Len(Str)
result = ""
Dim i
For i = 1 To l
Select Case Mid(Str, i, 1)
Case "<"
result = result + "<"
Case ">"
result = result + ">"
Case Chr(13)
If session("admin_system") = "" Then
result = result + "<br>"
End If
Case Chr(34)
result = result + """
Case "&"
result = result + "&"
Case Chr(32)
‘'result = result + " "
If i + 1<= l And i -1>0 Then
If Mid(Str, i + 1, 1) = Chr(32) or Mid(Str, i + 1, 1) = Chr(9) or Mid(Str, i -1, 1) = Chr(32) or Mid(Str, i -1, 1) = Chr(9) Then
result = result + " "
Else
result = result + " "
End If
Else
result = result + " "
End If
Case Chr(9)
result = result + " "
Case Else
result = result + Mid(Str, i, 1)
End Select
Next
Htmlout = result
End Function
Rem - - - textarea顯示用 - - -
CODE Copy ...
Function htmlencode1(fString)
If fString<>"" And Not IsNull(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 = ""
End If
End Function
Rem - - - 頁(yè)面顯示用 - - -
CODE Copy ...
Function htmlencode2(fString)
If fString<>"" And Not IsNull(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 = ""
End If
End Function
Rem - - - 取出指定字符串前后的字符串方法 - - -
CODE Copy ...
Function GetStrs(str1, CharFlag, Dflag)
Dim tmpstr
If Dflag = 0 Then‘'取左
pos1 = InStr(str1, charFlag)
If pos1<= 20 Then
tmpstr = Left(str1, pos1 -1)
Else
tmpstr = Mid(str1, pos1 -20, 20)
End If
Else ‘'取右
pos1 = InStr(str1, charFlag) + Len(charFlag)
If Len(str1) - pos1<= 20 Then
tmpstr = Right(str1, Len(str1) - pos1)
Else
tmpstr = Mid(str1, pos1 + 1, 20)
End If
End If
GetStrs = tmpstr
End Function
Rem - - - 取出文件名 - - -
CODE Copy ...
Function GetFileName(Str)
pos = InStr(Str, ".")
If Str<>"" Then
Str = Mid(Str, pos, Len(Str))
End If
GetFileName = Str
End Function
Rem - - - 取到瀏覽器版本轉(zhuǎn)換字符串 - - -
CODE Copy ...
Function browser()
Dim text
text = Request.ServerVariables("HTTP_USER_AGENT")
If InStr(text, "MSIE 5.5")>0 Then
browser = "IE 5.5"
ElseIf InStr(text, "MSIE 6.0")>0 Then
browser = "IE 6.0"
ElseIf InStr(text, "MSIE 5.01")>0 Then
browser = "IE 5.01"
ElseIf InStr(text, "MSIE 5.0")>0 Then
browser = "IE 5.00"
ElseIf InStr(text, "MSIE 4.0")>0 Then
browser = "IE 4.01"
Else
browser = "未知"
End If
End Function
Rem - - - 取到系統(tǒng)腳本轉(zhuǎn)換字符串 - - -
CODE Copy ...
Function System(text)
If InStr(text, "NT 5.1")>0 Then
System = System + "Windows XP"
ElseIf InStr(text, "NT 5")>0 Then
System = System + "Windows 2000"
ElseIf InStr(text, "NT 4")>0 Then
System = System + "Windows NT4"
ElseIf InStr(text, "4.9")>0 Then
System = System + "Windows ME"
ElseIf InStr(text, "98")>0 Then
System = System + "Windows 98"
ElseIf InStr(text, "95")>0 Then
System = System + "Windows 95"
Else
System = System + "未知"
End If
End Function
Rem - - - = 刪除文件 - - -
CODE Copy ...
Function delfile(filepath)
imangepath = Trim(filepath)
Path = server.MapPath(imangepath)
Set fs = server.CreateObject("Scripting.FileSystemObject")
If FS.FileExists(Path) Then
FS.DeleteFile(Path)
End If
Set fs = Nothing
End Function
Rem - - - 得到真實(shí)的客戶端IP - - -
CODE Copy ...
Public Function GetClientIP()
Dim uIpAddr
‘' 本函數(shù)參考webcn.Net / AspHouse 文獻(xiàn)<取真實(shí)的客戶IP>
uIpAddr = Request.ServerVariables("HTTP_X_FORWARDED_FOR")
If uIpAddr = "" Then uIpAddr = Request.ServerVariables("REMOTE_ADDR")
GetClientIP = uIpAddr
uIpAddr = ""
End Function
%>
數(shù)據(jù)庫(kù)查詢中的特殊字符的問(wèn)題
在進(jìn)行數(shù)據(jù)庫(kù)的查詢時(shí)，會(huì)經(jīng)常遇到這樣的情況：
例如想在一個(gè)用戶數(shù)據(jù)庫(kù)中查詢他的用戶名和他的密碼，但恰好該用戶使用的名字和密碼中有特殊的字符，例如單引號(hào)，“|”號(hào)，雙引號(hào)或者連字符“&”。
例如他的名字是1"test，密碼是A|&900
這時(shí)當(dāng)你執(zhí)行以下的查詢語(yǔ)句時(shí)，肯定會(huì)報(bào)錯(cuò)：
SQL = "Select * FROM SecurityLevel Where UID="" & UserID & """
SQL = SQL & " AND PWD="" & Password & """
因?yàn)槟愕腟QL將會(huì)是這樣：
Select * FROM SecurityLevel Where UID="1"test" AND PWD="A|&900"
在SQL中，"|"為分割字段用的，顯然會(huì)出錯(cuò)了。現(xiàn)在提供下面的幾個(gè)函數(shù) 專門用來(lái)處理這些頭疼的東西：
Quoted from Unkown:
<%
Function ReplaceStr (TextIn, ByVal SearchStr As String, _
ByVal Replacement As String, _
ByVal CompMode As Integer)
Dim WorkText As String, Pointer As Integer
If IsNull(TextIn) Then
ReplaceStr = Null
Else
WorkText = TextIn
Pointer = InStr(1, WorkText, SearchStr, CompMode)
Do While Pointer > 0
WorkText = Left(WorkText, Pointer - 1) & Replacement & _
Mid(WorkText, Pointer + Len(SearchStr))
Pointer = InStr(Pointer + Len(Replacement), WorkText, SearchStr, CompMode)
Loop
ReplaceStr = WorkText
End If
End Function
Function SQLFixup(TextIn)
SQLFixup = ReplaceStr(TextIn, """, """", 0)
End Function
Function JetSQLFixup(TextIn)
Dim Temp
Temp = ReplaceStr(TextIn, """, """", 0)
JetSQLFixup = ReplaceStr(Temp, "|", "" & Chr(124) & "", 0)
End Function
Function FindFirstFixup(TextIn)
Dim Temp
Temp = ReplaceStr(TextIn, """, "" & chr(39) & "", 0)
FindFirstFixup = ReplaceStr(Temp, "|", "" & Chr(124) & "", 0)
End Function
Rem 借助RecordSet將二進(jìn)制流轉(zhuǎn)化成文本
Quoted from Unkown:
Function BinaryToString(biData, Size)
Const adLongVarChar = 201
Set RS = 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
End Function
%>
<%
'定義超全局變量
Dim URLSelf, URISelf
URISelf = Request.ServerVariables("SCRIPT_NAME")
If Request.QueryString = "" Then
URLSelf = URISelf
Else
URLSelf = URISelf & "?" & Request.QueryString
End If
Response.CharSet = "GB2312"
Response.Buffer = True
Response.Expires = -1
'===================================================================================
' 函數(shù)原型：GotoURL (URL)
'功能：轉(zhuǎn)到指定的URL
'參數(shù)：URL 要跳轉(zhuǎn)的URL
'返 回 值：無(wú)
'涉及的表：無(wú)
'===================================================================================
Public Function GotoURL(URL)
Response.Write "<script language=""JavaScript"">location.href='" & URL & "';</script>"
End Function
'===================================================================================
' 函數(shù)原型：MessageBox (Msg)
'功能：顯示消息框
'參數(shù)：要顯示的消息
'返 回 值：無(wú)
'涉及的表：無(wú)
'===================================================================================
Public Function MessageBox(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 "<script language=""JavaScript"">alert('" & msg & "');</script>"
End Function
'===================================================================================
' 函數(shù)原型：ReturnValue (bolValue)
'功能：設(shè)置Window對(duì)象的返回值：只能是布爾值
'參數(shù)：返回值
'返 回 值：無(wú)
'涉及的表：無(wú)
'===================================================================================
Public Function ReturnValue(bolValue)
If bolValue Then
Response.Write "<script language=""JavaScript"">window.returnValue=true;</script>"
Else
Response.Write "<script language=""JavaScript"">window.returnValue=false;</script>"
End If
End Function
'===================================================================================
' 函數(shù)原型：GoBack (URL)
'功能：后退
'參數(shù)：無(wú)
'返 回 值：無(wú)
'涉及的表：無(wú)
'===================================================================================
Public Function GoBack()
Response.Write "<script language=""JavaScript"">history.go(-1);</script>"
End Function
'===================================================================================
' 函數(shù)原型：CloseWindow ()
'功能：關(guān)閉窗口
'參數(shù)：無(wú)
'返 回 值：無(wú)
'涉及的表：無(wú)
'===================================================================================
Public Function CloseWindow()
Response.Write "<script language=""JavaScript"">window.opener=null;window.close();</script>"
End Function
'===================================================================================
' 函數(shù)原型：RefreshParent ()
'功能：刷新父框架
'參數(shù)：無(wú)
'返 回 值：無(wú)
'涉及的表：無(wú)
'===================================================================================
Public Function RefreshParent()
Response.Write "<script language=""JavaScript"">if(parent!=self) parent.location.reload();</script>"
End Function
'===================================================================================
' 函數(shù)原型：RefreshTop ()
'功能：刷新頂級(jí)框架
'參數(shù)：無(wú)
'返 回 值：無(wú)
'涉及的表：無(wú)
'===================================================================================
Public Function RefreshTop()
Response.Write "<script language=""JavaScript"">if(top!=self) top.location.reload();</script>"
End Function
'===================================================================================
' 函數(shù)原型：GenPassword (intLen,PassMask)
'功能：生成隨機(jī)密碼
'參數(shù)：intLen新密碼長(zhǎng)度
'PassMask生成密碼的掩碼默認(rèn)為空
'返 回 值：無(wú)
'涉及的表：無(wú)
'===================================================================================
Public Function GenPassword(intLen, PassMask)
Dim iCnt, PosTemp
Randomize
If PassMask = "" Then
PassMask = "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789abcdefghijklmnopqrstuvwxyz"
End If
For iCnt = 1 To intLen
PosTemp = Fix(Rnd(1) * (Len(PassMask))) + 1
GenPassword = GenPassword & Mid(PassMask, PosTemp, 1)
Next
End Function
'===================================================================================
' 函數(shù)原型：GenSerialString ()
'功能：生成序列號(hào)
'參數(shù)：無(wú)
'返 回 值：無(wú)
'涉及的表：無(wú)
'===================================================================================
Public Function GenSerialString()
GenSerialString = Year(Now())
If Month(Now())<10 Then
GenSerialString = GenSerialString & "0"
End If
GenSerialString = GenSerialString & Month(Now())
If Day(Now())<10 Then
GenSerialString = GenSerialString & "0"
End If
GenSerialString = GenSerialString & Day(Now())
If Hour(Now())<10 Then
GenSerialString = GenSerialString & "0"
End If
GenSerialString = GenSerialString & Hour(Now())
If Minute(Now())<10 Then
GenSerialString = GenSerialString & "0"
End If
GenSerialString = GenSerialString & Minute(Now())
If Second(Now())<10 Then
GenSerialString = GenSerialString & "0"
End If
GenSerialString = GenSerialString & Second(Now())
GenSerialString = GenSerialString & GenPassword(6, "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ")
End Function
'===================================================================================
' 函數(shù)原型：ChangePage(URLTemplete,PageIndex)
'功能：根據(jù)URL模板生成新的頁(yè)面URL
'參數(shù)：URLTempleteURL模板
' PageIndex新的頁(yè)碼
'返 回 值：生成的URL
'涉及的表：無(wú)
'===================================================================================
Public Function ChangePage(URLTemplete, PageIndex)
ChangePage = SetQueryString(URLTemplete, "PAGE", PageIndex)
End Function
'===================================================================================
' 函數(shù)原型：BuildPath(sPath)
'功能：根據(jù)指定的路徑創(chuàng)建目錄
'參數(shù)：sPathURL模板
'返 回 值：如果成功，返回空字符串，否則返回錯(cuò)誤信息和錯(cuò)誤位置
'涉及的表：無(wú)
'===================================================================================
Public Function BuildPath (sPath)
Dim iCnt
Dim Path
Dim BasePath
Path = Split(sPath, "/")
If Left(sPath, 1) = "/" or Left(sPath, 1) = "\" Then
BasePath = Server.MapPath("/")
Else
BasePath = Server.MapPath(".")
End If
Dim cPath, oFso
cPath = BasePath
BuildPath = ""
Set oFso = Server.CreateObject("Scripting.FileSystemObject")
For iCnt = LBound(Path) To UBound(Path)
If Trim(Path(iCnt))<>"" Then
cPath = cPath & "\" & Trim(Path(iCnt))
If Not oFso.FolderExists(cPath) Then
On Error Resume Next
oFso.CreateFolder cPath
If Err.Number<>0 Then
BuildPath = Err.Description & "[" & cPath & "]"
Exit For
End If
On Error GoTo 0
End If
End If
Next
Set oFso = Nothing
End Function
'===================================================================================
' 函數(shù)原型：GetUserAgentInfo(ByRef vSoft,ByRef vOs)
'功能：獲取客戶端操作系統(tǒng)和瀏覽器信息
'參數(shù)：vSoft瀏覽器信息
'vOs操作系統(tǒng)信息
'返 回 值：無(wú)
'涉及的表：無(wú)
'===================================================================================
Public Function GetUserAgentInfo(ByRef vSoft, ByRef vOs)
Dim theSoft
theSoft = Request.ServerVariables("HTTP_USER_AGENT")
' 瀏覽器
If InStr(theSoft, "NetCaptor") Then
vSoft = "NetCaptor"
ElseIf InStr(theSoft, "MSIE 6") Then
vSoft = "MSIE 6.0"
ElseIf InStr(theSoft, "MSIE 5.5+") Then
vSoft = "MSIE 5.5"
ElseIf InStr(theSoft, "MSIE 5") Then
vSoft = "MSIE 5.0"
ElseIf InStr(theSoft, "MSIE 4") Then
vSoft = "MSIE 4.0"
ElseIf InStr(theSoft, "Netscape") Then
vSoft = "Netscape"
ElseIf InStr(theSoft, "Opera") Then
vSoft = "Opera"
Else
vSoft = "Other"
End If
' 操作系統(tǒng)
If InStr(theSoft, "Windows NT 5.0") Then
vOs = "Windows 2000"
ElseIf InStr(theSoft, "Windows NT 5.1") Then
vOs = "Windows XP"
ElseIf InStr(theSoft, "Windows NT 5.2") Then
vOs = "Windows 2003"
ElseIf InStr(theSoft, "Windows NT") Then
vOs = "Windows NT"
ElseIf InStr(theSoft, "Windows 9") Then
vOs = "Windows 9x"
ElseIf InStr(theSoft, "unix") Then
vOs = "Unix"
ElseIf InStr(theSoft, "linux") Then
vOs = "Linux"
ElseIf InStr(theSoft, "SunOS") Then
vOs = "SunOS"
ElseIf InStr(theSoft, "BSD") Then
vOs = "BSD"
ElseIf InStr(theSoft, "Mac") Then
vOs = "Mac"
Else
vOs = "Other"
End If
End Function
'===================================================================================
' 函數(shù)原型：GetRegexpObject()
'功能：獲得一個(gè)正則表達(dá)式對(duì)象
'參數(shù)：無(wú)
'返 回 值：正則表達(dá)式對(duì)象
'涉及的表：無(wú)
'===================================================================================
Public Function GetRegExpObject(sPattern)
Dim r
Set r = New RegExp
r.Global = True
r.IgnoreCase = True
r.MultiLine = True
r.Pattern = sPattern
Set GetRegexpObject = r
Set r = Nothing
End Function
'===================================================================================
' 函數(shù)原型：RegExpTest(pattern,string)
'功能：正則表達(dá)式檢測(cè)
'參數(shù)：pattern模式字符串
'string待檢查的字符串
'返 回 值：是否匹配
'涉及的表：無(wú)
'===================================================================================
Public Function RegExpTest(p, s)
Dim r
Set r = GetRegExpObject(p)
RegExpTest = r.Test(s)
Set r = Nothing
End Function
'===================================================================================
' 函數(shù)原型：RegExpReplace(sSource,sPattern,sRep)
'功能：正則表達(dá)式替換
'參數(shù)：sSource要替換的源字符串
'sPattern模式字符串
'sRep要替換的目標(biāo)字符串
'返 回 值：替換后的字符串
'涉及的表：無(wú)
'===================================================================================
Public Function RegExpReplace(sSource, sPattern, sRep)
Dim r
Set r = GetRegExpTest(sPattern)
RegExpReplace = r.Replace(sSource, sRep)
Set r = Nothing
End Function
'===================================================================================
' 函數(shù)原型：CreateXMLParser()
'功能：創(chuàng)建一個(gè)盡可能高版本的XMLDOM
'參數(shù)：無(wú)
'返 回 值：IDOMDocument對(duì)象
'涉及的表：無(wú)
'===================================================================================
Public Function CreateXMLParser()
On Error Resume Next
Set CreateXMLParser = Server.CreateObject("MSXML2.DOMDocument.4.0")
If Err.Number<>0 Then
Err.Clear
Set CreateXMLParser = Server.CreateObject("MSXML2.DOMDocument.3.0")
If Err.Number<>0 Then
Err.Clear
Set CreateXMLParser = Server.CreateObject("MSXML2.DOMDocument.2.6")
If Err.Number<>0 Then
Err.Clear
Set CreateXMLParser = Server.CreateObject("MSXML2.DOMDocument")
If Err.Number<>0 Then
Err.Clear
Set CreateXMLParser = Server.CreateObject("Microsoft.XMLDOM")
If Err.Number<>0 Then
Err.Clear
Set CreateXMLParser = Nothing
Else
Exit Function
End If
Else
Exit Function
End If
Else
Exit Function
End If
Else
Exit Function
End If
Else
Exit Function
End If
On Error GoTo 0
End Function
'===================================================================================
' 函數(shù)原型：CreateHTTPPoster()
'功能：創(chuàng)建一個(gè)盡可能高版本的XMLHTTP
'參數(shù)：ServerOrClient創(chuàng)建ServerXMLHTTP還是XMLHTTP
'返 回 值：IXMLHTTP對(duì)象
'涉及的表：無(wú)
'===================================================================================
Public Function CreateHTTPPoster(soc)
Dim s
If soc Then
s = "ServerXMLHTTP"
Else
s = "XMLHTTP"
End If
On Error Resume Next
Set CreateHTTPPoster = Server.CreateObject("MSXML2." & s & ".4.0")
If Err.Number<>0 Then
Err.Clear
Set CreateHTTPPoster = Server.CreateObject("MSXML2." & s & ".3.0")
If Err.Number<>0 Then
Err.Clear
Set CreateHTTPPoster = Server.CreateObject("MSXML2." & s)
If Err.Number<>0 Then
Set CreateHTTPPoster = Nothing
Else
Exit Function
End If
Else
Exit Function
End If
Else
Exit Function
End If
On Error GoTo 0
End Function
'===================================================================================
' 函數(shù)原型：XMLThrowError (errCode,errReason)
'功能：拋出一個(gè)XML錯(cuò)誤消息
'參數(shù)：errCode錯(cuò)誤編碼
'errReason錯(cuò)誤原因
'返 回 值：無(wú)
'涉及的表：無(wú)
'===================================================================================
Public Sub XMLThrowError (errCode, errReason)
Response.Clear
Response.ContentType = "text/xml"
Response.Write"<?xml version=""1.0"" encoding=""gb2312"" standalone=""yes"" ?>" & vbCrLf & _
"<ERROR CODE=""" & errCode & """ REASON=""" & errReason & """ />" & vbCrLf
Response.Flush
Response.End
End Sub
'===================================================================================
' 函數(shù)原型：GetXMLNodeValue(ByRef xmlDom,sFilter,sDefValue)
'功能：從一個(gè)XML文檔中查找指定節(jié)點(diǎn)的值
'參數(shù)：xmlDomXML文檔
'sFilterXPATH定位字符串
'sDefValue默認(rèn)值
'返 回 值：無(wú)
'涉及的表：無(wú)
'===================================================================================
Public Function GetXMLNodeValue(ByRef xmlDom, sFilter, sDefValue)
Dim oNode
Set oNode = xmlDom.selectSingleNode(sFilter)
If TypeName(oNode) = "Nothing" or TypeName(oNode) = "Null" or TypeName(oNode) = "Empty" Then
GetXMLNodeValue = sDefValue
Set oNode = Nothing
Else
GetXMLNodeValue = Trim(oNode.Text)
Set oNode = Nothing
End If
End Function
'===================================================================================
' 函數(shù)原型：GetXMLNodeAttribute(ByRef xmlDom,sFilter,sName,sDefValue)
'功能：從一個(gè)XML文檔中查找指定節(jié)點(diǎn)的指定屬性
'參數(shù)：xmlDomXML文檔
'sFilterXPATH定位字符串
'sName要查詢的屬性名稱
'sDefValue默認(rèn)值
'返 回 值：無(wú)
'涉及的表：無(wú)
'===================================================================================
Public Function GetXMLNodeAttribute(ByRef xmlDom, sFilter, sName, sDefValue)
Dim oNode
Set oNode = xmlDom.selectSingleNode(sFilter)
If TypeName(oNode) = "Nothing" or TypeName(oNode) = "Null" or TypeName(oNode) = "Empty" Then
GetXMLNodeAttribute = sDefValue
Set oNode = Nothing
Else
Dim pTemp
Set pTemp = oNode.getAttribute(sName)
If TypeName(pTemp) = "Nothing" or TypeName(pTemp) = "Null" or TypeName(pTemp) = "Empty" Then
GetXMLNodeAttribute = sDefValue
Set oNode = Nothing
Set pTemp = Nothing
Else
GetXMLNodeAttribute = Trim(pTemp.Value)
Set oNode = Nothing
Set pTemp = Nothing
End If
End If
End Function
'===================================================================================
' 函數(shù)原型：GetQueryStringNumber (FieldName,defValue)
'功能：從QueryString獲取一個(gè)整數(shù)
'參數(shù)：FieldName參數(shù)名
'defValue默認(rèn)值
'返 回 值：無(wú)
'涉及的表：無(wú)
'===================================================================================
Public Function GetQueryStringNumber (FieldName, defValue)
Dim r
r = Request.QueryString(FieldName)
If r = "" Then
GetQueryStringNumber = defValue
Exit Function
Else
If Not IsNumeric(r) Then
GetQueryStringNumber = defValue
Exit Function
Else
On Error Resume Next
r = CDbl(r)
If Err.Number<>0 Then
Err.Clear
GetQueryStringNumber = defValue
Exit Function
Else
GetQueryStringNumber = r
End If
On Error GoTo 0
End If
End If
End Function
'===================================================================================
' 函數(shù)原型：I(yíng)If (testExpr,value1,value2)
'功能：相當(dāng)于C/C++里面的 ?: 運(yùn)算符
'參數(shù)：testExprBoolean表達(dá)式
'value1testExpr=True 時(shí)的取值
'value2testExpr=False 時(shí)的取值
'返 回 值：如果testExpr為True返回value1否則返回value2
'涉及的表：無(wú)
'說(shuō)明：VBScript里沒有Iif函數(shù)
'===================================================================================
Public Function IIf(testExpr, value1, value2)
If testExpr = True Then
IIf = value1
Else
IIf = value2
End If
End Function
'===================================================================================
' 函數(shù)原型：URLEncoding (v,f)
'功能：URL編碼函數(shù)
'參數(shù)：v中英文混合字符串
'f是否對(duì)ASCII字符編碼
'返 回 值：編碼后的ASC字符串
'涉及的表：無(wú)
'===================================================================================
Public Function URLEncoding(v, f)
Dim s, t, i, j, h, l, x
s = ""
x = Len(v)
For i = 1 To x
t = Mid(v, i, 1)
j = Asc(t)
If j> 0 Then
If f Then
s = s & "%" & Right("00" & Hex(Asc(t)), 2)
Else
s = s & t
End If
Else
If j < 0 Then j = j + &H10000
h = (j And &HFF00) \ &HFF
l = j And &HFF
s = s & "%" & Hex(h) & "%" & Hex(l)
End If
Next
URLEncoding = s
End Function
'===================================================================================
' 函數(shù)原型：URLDecoding (sIn)
'功能：URL解碼碼函數(shù)
'參數(shù)：vURL編碼的字符串
'返 回 值：解碼后的字符串
'涉及的表：無(wú)
'===================================================================================
Public Function URLDecoding(Sin)
Dim s, i, l, c, t, n
s = ""
l = Len(Sin)
For i = 1 To l
c = Mid(Sin, i, 1)
If c<>"%" Then
s = s & c
Else
c = Mid(Sin, i + 1, 2)
i = i + 2
t = CInt("&H" & c)
If t<&H80 Then
s = s & Chr(t)
Else
c = Mid(Sin, i + 1, 3)
If Left(c, 1)<>"%" Then
URLDecoding = s
Exit Function
Else
c = Right(c, 2)
n = CInt("&H" & c)
t = t * 256 + n -65536
s = s & Chr(t)
i = i + 3
End If
End If
End If
Next
URLDecoding = s
End Function
'===================================================================================
' 函數(shù)原型：Bytes2BSTR (v)
'功能：UTF-8編碼轉(zhuǎn)換到正常的GB2312
'參數(shù)：vUTF-8編碼字節(jié)流
'返 回 值：解碼后的字符串
'涉及的表：無(wú)
'===================================================================================
Public Function Bytes2BSTR(v)
Dim r, i, t, n
r = ""
For i = 1 To LenB(v)
t = AscB(MidB(v, i, 1))
If t < &H80 Then
r = r & Chr(t)
Else
n = AscB(MidB(v, i + 1, 1))
r = r & Chr(CLng(t) * &H100 + CInt(n))
i = i + 1
End If
Next
Bytes2BSTR = r
End Function
%>
'*******************************************************************
'取得IP地址
'*******************************************************************
Function Userip()
Dim GetClientIP
'如果客戶端用了代理服務(wù)器，則應(yīng)該用ServerVariables("HTTP_X_FORWARDED_FOR")方法
GetClientIP = Request.ServerVariables("HTTP_X_FORWARDED_FOR")
If GetClientIP = "" or IsNull(GetClientIP) or IsEmpty(GetClientIP) Then
'如果客戶端沒用代理，應(yīng)該用Request.ServerVariables("REMOTE_ADDR")方法
GetClientIP = Request.ServerVariables("REMOTE_ADDR")
End If
Userip = GetClientIP
End Function
'*******************************************************************
'轉(zhuǎn)換IP地址
'*******************************************************************
Function cip(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)
End Function
'*******************************************************************
' 彈出對(duì)話框
'*******************************************************************
Sub alert(message)
message = Replace(message, "'", "\'")
Response.Write ("<script>alert('" & message & "')</script>")
End Sub
'*******************************************************************
' 返回上一頁(yè)，一般用在判斷信息提交是否完全之后
'*******************************************************************
Sub GoBack()
Response.Write ("<script>history.go(-1)</script>")
End Sub
'*******************************************************************
' 重定向另外的連接
'*******************************************************************
Sub Go(url)
Response.Write ("<script>location.href('" & url & "')</script>")
End Sub
'*******************************************************************
' 我比較喜歡將以上三個(gè)結(jié)合起來(lái)使用
'*******************************************************************
Function Alert(message, gourl)
message = Replace(message, "'", "\'")
If gourl = "-1" Then
Response.Write ("<script language=javascript>alert('" & message & "');history.go(-1)</script>")
Else
Response.Write ("<script language=javascript>alert('" & message & "');location='" & gourl &"'</script>")
End If
Response.End()
End Function
'*******************************************************************
' 指定秒數(shù)重定向另外的連接
'*******************************************************************
Sub GoPage(url, s)
s = s * 1000
Response.Write "<SCRIPT LANGUAGE=JavaScript>"
Response.Write "window.setTimeout("&Chr(34)&"window.navigate('"&url&"')"&Chr(34)&","&s&")"
Response.Write "</script>"
End Sub
'*******************************************************************
' 判斷數(shù)字是否整形
'*******************************************************************
Function isInteger(para)
On Error Resume Next
Dim Str
Dim l, i
If IsNull(para) Then
isInteger = False
Exit Function
End If
Str = CStr(para)
If Trim(Str) = "" Then
isInteger = False
Exit Function
End If
l = Len(Str)
For i = 1 To l
If Mid(Str, i, 1)>"9" or Mid(Str, i, 1)<"0" Then
isInteger = False
Exit Function
End If
Next
isInteger = True
If Err.Number<>0 Then Err.Clear
End Function
'*******************************************************************
' 獲得文件擴(kuò)展名
'*******************************************************************
Function GetExtend(filename)
Dim tmp
If filename<>"" Then
tmp = Mid(filename, instrrev(filename, ".") + 1, Len(filename) - instrrev(filename, "."))
tmp = LCase(tmp)
If InStr(1, tmp, "asp")>0 or InStr(1, tmp, "php")>0 or InStr(1, tmp, "php3")>0 or InStr(1, tmp, "aspx")>0 Then
getextend = "txt"
Else
getextend = tmp
End If
Else
getextend = ""
End If
End Function
' *----------------------------------------------------------------------------
' * 函數(shù)：CheckIn
' * 描述：檢測(cè)參數(shù)是否有SQL危險(xiǎn)字符
' * 參數(shù)：str要檢測(cè)的數(shù)據(jù)
' * 返回：FALSE：安全 TRUE：不安全
' * 作者：
' * 日期：
' *----------------------------------------------------------------------------
Function CheckIn(Str)
If InStr(1, Str, Chr(39))>0 or InStr(1, Str, Chr(34))>0 or InStr(1, Str, Chr(59))>0 Then
CheckIn = True
Else
CheckIn = False
End If
End Function
' *----------------------------------------------------------------------------
' * 函數(shù)：HTMLEncode
' * 描述：過(guò)濾HTML代碼
' * 參數(shù)：--
' * 返回：--
' * 作者：
' * 日期：
' *----------------------------------------------------------------------------
Function HTMLEncode(fString)
If Not IsNull(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
End If
End Function
' *----------------------------------------------------------------------------
' * 函數(shù)：HTMLcode
' * 描述：過(guò)濾表單字符
' * 參數(shù)：--
' * 返回：--
' * 作者：
' * 日期：
' *----------------------------------------------------------------------------
Function HTMLcode(fString)
If Not IsNull(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
End If
End Function
%>
<%
1.檢查是否有效郵件地址
Function CheckEmail(strEmail)
Dim re
Set re = New RegExp
re.Pattern = "^[w-.]{1,}@([da-zA-Z-]{1,}.){1,}[da-zA-Z-]{2,3}$"
re.IgnoreCase = True
CheckEmail = re.Test(strEmail)
End Function
2.測(cè)試變量是否為空值，空值的含義包括：變量不存在 / 為空，對(duì)象為Nothing，0，空數(shù)組，字符串為空
Function IsBlank(ByRef Var)
IsBlank = False
Select Case True
Case IsObject(Var)
If Var Is Nothing Then IsBlank = True
Case IsEmpty(Var), IsNull(Var)
IsBlank = True
Case IsArray(Var)
If UBound(Var) = 0 Then IsBlank = True
Case IsNumeric(Var)
If (Var = 0) Then IsBlank = True
Case Else
If Trim(Var) = "" Then IsBlank = True
End Select
End Function
3.得到瀏覽器目前的URL
Function GetCurURL()
If Request.ServerVariables("HTTPS") = "on" Then
GetCurrentURL = "https://"
Else
GetCurrentURL = "http://"
End If
GetCurURL = GetCurURL & Request.ServerVariables("SERVER_NAME")
If (Request.ServerVariables("SERVER_PORT") <> 80) Then GetCurURL = GetCurURL & ":" & Request.ServerVariables("SERVER_PORT")
GetCurURL = GetCurURL & Request.ServerVariables("URL")
If (Request.QueryString <> "") Then GetCurURL = GetCurURL & "?" & Request.QueryString
End Function
4.MD5加密函數(shù)
Private Const BITS_TO_A_BYTE = 8
Private Const BYTES_TO_A_WORD = 4
Private Const BITS_TO_A_WORD = 32
Private m_lOnBits(30)
Private m_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)
Private Function LShift(lValue, iShiftBits)
If iShiftBits = 0 Then
LShift = lValue
Exit Function
ElseIf iShiftBits = 31 Then
If lValue And 1 Then
LShift = &H80000000
Else
LShift = 0
End If
Exit Function
ElseIf iShiftBits < 0 or iShiftBits > 31 Then
Err.Raise 6
End If
If (lValue And m_l2Power(31 - iShiftBits)) Then
LShift = ((lValue And m_lOnBits(31 - (iShiftBits + 1))) * m_l2Power(iShiftBits)) or &H80000000
Else
LShift = ((lValue And m_lOnBits(31 - iShiftBits)) * m_l2Power(iShiftBits))
End If
End Function
Private Function RShift(lValue, iShiftBits)
If iShiftBits = 0 Then
RShift = lValue
Exit Function
ElseIf iShiftBits = 31 Then
If lValue And &H80000000 Then
RShift = 1
Else
RShift = 0
End If
Exit Function
ElseIf iShiftBits < 0 or iShiftBits > 31 Then
Err.Raise 6
End If
RShift = (lValue And &H7FFFFFFE) m_l2Power(iShiftBits)
If (lValue And &H80000000) Then
RShift = (RShift or (&H40000000 m_l2Power(iShiftBits - 1)))
End If
End Function
Private Function RotateLeft(lValue, iShiftBits)
RotateLeft = LShift(lValue, iShiftBits) or RShift(lValue, (32 - iShiftBits))
End Function
Private Function AddUnsigned(lX, lY)
Dim lX4
Dim lY4
Dim lX8
Dim lY8
Dim lResult
lX8 = lX And &H80000000
lY8 = lY And &H80000000
lX4 = lX And &H40000000
lY4 = lY And &H40000000
lResult = (lX And &H3FFFFFFF) + (lY And &H3FFFFFFF)
If lX4 And lY4 Then
lResult = lResult Xor &H80000000 Xor lX8 Xor lY8
ElseIf lX4 or lY4 Then
If lResult And &H40000000 Then
lResult = lResult Xor &HC0000000 Xor lX8 Xor lY8
Else
lResult = lResult Xor &H40000000 Xor lX8 Xor lY8
End If
Else
lResult = lResult Xor lX8 Xor lY8
End If
AddUnsigned = lResult
End Function
Private Function F(x, y, z)
F = (x And y) or ((Not x) And z)
End Function
Private Function G(x, y, z)
G = (x And z) or (y And (Not z))
End Function
Private Function H(x, y, z)
H = (x Xor y Xor z)
End Function
Private Function I(x, y, z)
I = (y Xor (x or (Not z)))
End Function
Private Sub FF(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)
End Sub
Private Sub GG(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)
End Sub
Private Sub HH(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)
End Sub
Private Sub II(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)
End Sub
Private Function ConvertToWordArray(sMessage)
Dim lMessageLength
Dim lNumberOfWords
Dim lWordArray()
Dim lBytePosition
Dim lByteCount
Dim lWordCount
Const MODULUS_BITS = 512
Const CONGRUENT_BITS = 448
lMessageLength = Len(sMessage)
lNumberOfWords = (((lMessageLength + ((MODULUS_BITS - CONGRUENT_BITS) BITS_TO_A_BYTE)) (MODULUS_BITS BITS_TO_A_BYTE)) + 1) * (MODULUS_BITS BITS_TO_A_WORD)
ReDim lWordArray(lNumberOfWords - 1)
lBytePosition = 0
lByteCount = 0
Do Until lByteCount >= lMessageLength
lWordCount = lByteCount BYTES_TO_A_WORD
lBytePosition = (lByteCount Mod BYTES_TO_A_WORD) * BITS_TO_A_BYTE
lWordArray(lWordCount) = lWordArray(lWordCount) or LShift(Asc(Mid(sMessage, lByteCount + 1, 1)), lBytePosition)
lByteCount = lByteCount + 1
Loop
lWordCount = lByteCount BYTES_TO_A_WORD
lBytePosition = (lByteCount Mod BYTES_TO_A_WORD) * BITS_TO_A_BYTE
lWordArray(lWordCount) = lWordArray(lWordCount) or LShift(&H80, lBytePosition)
lWordArray(lNumberOfWords - 2) = LShift(lMessageLength, 3)
lWordArray(lNumberOfWords - 1) = RShift(lMessageLength, 29)
ConvertToWordArray = lWordArray
End Function
Private Function WordToHex(lValue)
Dim lByte
Dim lCount
For lCount = 0 To 3
lByte = RShift(lValue, lCount * BITS_TO_A_BYTE) And m_lOnBits(BITS_TO_A_BYTE - 1)
WordToHex = WordToHex & Right("0" & Hex(lByte), 2)
Next
End Function
Public Function MD5(sMessage)
Dim x
Dim k
Dim AA
Dim BB
Dim CC
Dim DD
Dim a
Dim b
Dim c
Dim d
Const S11 = 7
Const S12 = 12
Const S13 = 17
Const S14 = 22
Const S21 = 5
Const S22 = 9
Const S23 = 14
Const S24 = 20
Const S31 = 4
Const S32 = 11
Const S33 = 16
Const S34 = 23
Const S41 = 6
Const S42 = 10
Const S43 = 15
Const S44 = 21
x = ConvertToWordArray(sMessage)
a = &H67452301
b = &HEFCDAB89
c = &H98BADCFE
d = &H10325476
For k = 0 To UBound(x) Step 16
AA = a
BB = b
CC = c
DD = d
FF a, b, c, d, x(k + 0), S11, &HD76AA478
FF d, a, b, c, x(k + 1), S12, &HE8C7B756
FF c, d, a, b, x(k + 2), S13, &H242070DB
FF b, c, d, a, x(k + 3), S14, &HC1BDCEEE
FF a, b, c, d, x(k + 4), S11, &HF57C0FAF
FF d, a, b, c, x(k + 5), S12, &H4787C62A
FF c, d, a, b, x(k + 6), S13, &HA8304613
FF b, c, d, a, x(k + 7), S14, &HFD469501
FF a, b, c, d, x(k + 8), S11, &H698098D8
FF d, a, b, c, x(k + 9), S12, &H8B44F7AF
FF c, d, a, b, x(k + 10), S13, &HFFFF5BB1
FF b, c, d, a, x(k + 11), S14, &H895CD7BE
FF a, b, c, d, x(k + 12), S11, &H6B901122
FF d, a, b, c, x(k + 13), S12, &HFD987193
FF c, d, a, b, x(k + 14), S13, &HA679438E
FF b, c, d, a, x(k + 15), S14, &H49B40821
GG a, b, c, d, x(k + 1), S21, &HF61E2562
GG d, a, b, c, x(k + 6), S22, &HC040B340
GG c, d, a, b, x(k + 11), S23, &H265E5A51
GG b, c, d, a, x(k + 0), S24, &HE9B6C7AA
GG a, b, c, d, x(k + 5), S21, &HD62F105D
GG d, a, b, c, x(k + 10), S22, &H2441453
GG c, d, a, b, x(k + 15), S23, &HD8A1E681
GG b, c, d, a, x(k + 4), S24, &HE7D3FBC8
GG a, b, c, d, x(k + 9), S21, &H21E1CDE6
GG d, a, b, c, x(k + 14), S22, &HC33707D6
GG c, d, a, b, x(k + 3), S23, &HF4D50D87
GG b, c, d, a, x(k + 8), S24, &H455A14ED
GG a, b, c, d, x(k + 13), S21, &HA9E3E905
GG d, a, b, c, x(k + 2), S22, &HFCEFA3F8
GG c, d, a, b, x(k + 7), S23, &H676F02D9
GG b, c, d, a, x(k + 12), S24, &H8D2A4C8A
HH a, b, c, d, x(k + 5), S31, &HFFFA3942
HH d, a, b, c, x(k + 8), S32, &H8771F681
HH c, d, a, b, x(k + 11), S33, &H6D9D6122
HH b, c, d, a, x(k + 14), S34, &HFDE5380C
HH a, b, c, d, x(k + 1), S31, &HA4BEEA44
HH d, a, b, c, x(k + 4), S32, &H4BDECFA9
HH c, d, a, b, x(k + 7), S33, &HF6BB4B60
HH b, c, d, a, x(k + 10), S34, &HBEBFBC70
HH a, b, c, d, x(k + 13), S31, &H289B7EC6
HH d, a, b, c, x(k + 0), S32, &HEAA127FA
HH c, d, a, b, x(k + 3), S33, &HD4EF3085
HH b, c, d, a, x(k + 6), S34, &H4881D05
HH a, b, c, d, x(k + 9), S31, &HD9D4D039
HH d, a, b, c, x(k + 12), S32, &HE6DB99E5
HH c, d, a, b, x(k + 15), S33, &H1FA27CF8
HH b, c, d, a, x(k + 2), S34, &HC4AC5665
II a, b, c, d, x(k + 0), S41, &HF4292244
II d, a, b, c, x(k + 7), S42, &H432AFF97
II c, d, a, b, x(k + 14), S43, &HAB9423A7
II b, c, d, a, x(k + 5), S44, &HFC93A039
II a, b, c, d, x(k + 12), S41, &H655B59C3
II d, a, b, c, x(k + 3), S42, &H8F0CCC92
II c, d, a, b, x(k + 10), S43, &HFFEFF47D
II b, c, d, a, x(k + 1), S44, &H85845DD1
II a, b, c, d, x(k + 8), S41, &H6FA87E4F
II d, a, b, c, x(k + 15), S42, &HFE2CE6E0
II c, d, a, b, x(k + 6), S43, &HA3014314
II b, c, d, a, x(k + 13), S44, &H4E0811A1
II a, b, c, d, x(k + 4), S41, &HF7537E82
II d, a, b, c, x(k + 11), S42, &HBD3AF235
II c, d, a, b, x(k + 2), S43, &H2AD7D2BB
II b, 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))
End Function
5.SHA256 加密，256位的加密哦！安全性更高！
Private m_lOnBits(30)
Private m_l2Power(30)
Private K(63)
Private Const BITS_TO_A_BYTE = 8
Private Const BYTES_TO_A_WORD = 4
Private Const BITS_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
Private Function LShift(lValue, iShiftBits)
If iShiftBits = 0 Then
LShift = lValue
Exit Function
ElseIf iShiftBits = 31 Then
If lValue And 1 Then
LShift = &H80000000
Else
LShift = 0
End If
Exit Function
ElseIf iShiftBits < 0 or iShiftBits > 31 Then
Err.Raise 6
End If
If (lValue And m_l2Power(31 - iShiftBits)) Then
LShift = ((lValue And m_lOnBits(31 - (iShiftBits + 1))) * m_l2Power(iShiftBits)) or &H80000000
Else
LShift = ((lValue And m_lOnBits(31 - iShiftBits)) * m_l2Power(iShiftBits))
End If
End Function
Private Function RShift(lValue, iShiftBits)
If iShiftBits = 0 Then
RShift = lValue
Exit Function
ElseIf iShiftBits = 31 Then
If lValue And &H80000000 Then
RShift = 1
Else
RShift = 0
End If
Exit Function
ElseIf iShiftBits < 0 or iShiftBits > 31 Then
Err.Raise 6
End If
RShift = (lValue And &H7FFFFFFE) m_l2Power(iShiftBits)
If (lValue And &H80000000) Then
RShift = (RShift or (&H40000000 m_l2Power(iShiftBits - 1)))
End If
End Function
Private Function AddUnsigned(lX, lY)
Dim lX4
Dim lY4
Dim lX8
Dim lY8
Dim lResult
lX8 = lX And &H80000000
lY8 = lY And &H80000000
lX4 = lX And &H40000000
lY4 = lY And &H40000000
lResult = (lX And &H3FFFFFFF) + (lY And &H3FFFFFFF)
If lX4 And lY4 Then
lResult = lResult Xor &H80000000 Xor lX8 Xor lY8
ElseIf lX4 or lY4 Then
If lResult And &H40000000 Then
lResult = lResult Xor &HC0000000 Xor lX8 Xor lY8
Else
lResult = lResult Xor &H40000000 Xor lX8 Xor lY8
End If
Else
lResult = lResult Xor lX8 Xor lY8
End If
AddUnsigned = lResult
End Function
Private Function Ch(x, y, z)
Ch = ((x And y) Xor ((Not x) And z))
End Function
Private Function Maj(x, y, z)
Maj = ((x And y) Xor (x And z) Xor (y And z))
End Function
Private Function S(x, n)
S = (RShift(x, (n And m_lOnBits(4))) or LShift(x, (32 - (n And m_lOnBits(4)))))
End Function
Private Function R(x, n)
R = RShift(x, CInt(n And m_lOnBits(4)))
End Function
Private Function Sigma0(x)
Sigma0 = (S(x, 2) Xor S(x, 13) Xor S(x, 22))
End Function
Private Function Sigma1(x)
Sigma1 = (S(x, 6) Xor S(x, 11) Xor S(x, 25))
End Function
Private Function Gamma0(x)
Gamma0 = (S(x, 7) Xor S(x, 18) Xor R(x, 3))
End Function
Private Function Gamma1(x)
Gamma1 = (S(x, 17) Xor S(x, 19) Xor R(x, 10))
End Function
Private Function ConvertToWordArray(sMessage)
Dim lMessageLength
Dim lNumberOfWords
Dim lWordArray()
Dim lBytePosition
Dim lByteCount
Dim lWordCount
Dim lByte
Const MODULUS_BITS = 512
Const CONGRUENT_BITS = 448
lMessageLength = Len(sMessage)
lNumberOfWords = (((lMessageLength + ((MODULUS_BITS - CONGRUENT_BITS) BITS_TO_A_BYTE)) (MODULUS_BITS BITS_TO_A_BYTE)) + 1) * (MODULUS_BITS BITS_TO_A_WORD)
ReDim lWordArray(lNumberOfWords - 1)
lBytePosition = 0
lByteCount = 0
Do Until lByteCount >= lMessageLength
lWordCount = lByteCount BYTES_TO_A_WORD
lBytePosition = (3 - (lByteCount Mod BYTES_TO_A_WORD)) * BITS_TO_A_BYTE
lByte = AscB(Mid(sMessage, lByteCount + 1, 1))
lWordArray(lWordCount) = lWordArray(lWordCount) or LShift(lByte, lBytePosition)
lByteCount = lByteCount + 1
Loop
lWordCount = lByteCount BYTES_TO_A_WORD
lBytePosition = (3 - (lByteCount Mod BYTES_TO_A_WORD)) * BITS_TO_A_BYTE
lWordArray(lWordCount) = lWordArray(lWordCount) or LShift(&H80, lBytePosition)
lWordArray(lNumberOfWords - 1) = LShift(lMessageLength, 3)
lWordArray(lNumberOfWords - 2) = RShift(lMessageLength, 29)
ConvertToWordArray = lWordArray
End Function
Public Function SHA256(sMessage)
Dim HASH(7)
Dim M
Dim W(63)
Dim a
Dim b
Dim c
Dim d
Dim e
Dim f
Dim g
Dim h
Dim i
Dim j
Dim T1
Dim T2
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)
For i = 0 To UBound(M) Step 16
a = HASH(0)
b = HASH(1)
c = HASH(2)
d = HASH(3)
e = HASH(4)
f = HASH(5)
g = HASH(6)
h = HASH(7)
For j = 0 To 63
If j < 16 Then
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))
End If
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))
End Function
6.一個(gè)If語(yǔ)句的加工，以后可以用類似于PHP或JS的 If () ? ..
...代碼了
Function IIf(Condition, ValueIfTrue, ValueIfFalse)
If Condition Then
IIf = ValueIfTrue
Else
IIf = ValueIfFalse
End If
End Function
7.ASE加密函數(shù)
Private m_lOnBits(30)
Private m_l2Power(30)
Private m_bytOnBits(7)
Private m_byt2Power(7)
Private m_InCo(3)
Private m_fbsub(255)
Private m_rbsub(255)
Private m_ptab(255)
Private m_ltab(255)
Private m_ftable(255)
Private m_rtable(255)
Private m_rco(29)
Private m_Nk
Private m_Nb
Private m_Nr
Private m_fi(23)
Private m_ri(23)
Private m_fkey(119)
Private m_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
Private Function LShift(lValue, iShiftBits)
If iShiftBits = 0 Then
LShift = lValue
Exit Function
ElseIf iShiftBits = 31 Then
If lValue And 1 Then
LShift = &H80000000
Else
LShift = 0
End If
Exit Function
ElseIf iShiftBits < 0 or iShiftBits > 31 Then
Err.Raise 6
End If
If (lValue And m_l2Power(31 - iShiftBits)) Then
LShift = ((lValue And m_lOnBits(31 - (iShiftBits + 1))) * m_l2Power(iShiftBits)) or &H80000000
Else
LShift = ((lValue And m_lOnBits(31 - iShiftBits)) * m_l2Power(iShiftBits))
End If
End Function
Private Function RShift(lValue, iShiftBits)
If iShiftBits = 0 Then
RShift = lValue
Exit Function
ElseIf iShiftBits = 31 Then
If lValue And &H80000000 Then
RShift = 1
Else
RShift = 0
End If
Exit Function
ElseIf iShiftBits < 0 or iShiftBits > 31 Then
Err.Raise 6
End If
RShift = (lValue And &H7FFFFFFE) m_l2Power(iShiftBits)
If (lValue And &H80000000) Then
RShift = (RShift or (&H40000000 m_l2Power(iShiftBits - 1)))
End If
End Function
Private Function LShiftByte(bytValue, bytShiftBits)
If bytShiftBits = 0 Then
LShiftByte = bytValue
Exit Function
ElseIf bytShiftBits = 7 Then
If bytValue And 1 Then
LShiftByte = &H80
Else
LShiftByte = 0
End If
Exit Function
ElseIf bytShiftBits < 0 or bytShiftBits > 7 Then
Err.Raise 6
End If
LShiftByte = ((bytValue And m_bytOnBits(7 - bytShiftBits)) * m_byt2Power(bytShiftBits))
End Function
Private Function RShiftByte(bytValue, bytShiftBits)
If bytShiftBits = 0 Then
RShiftByte = bytValue
Exit Function
ElseIf bytShiftBits = 7 Then
If bytValue And &H80 Then
RShiftByte = 1
Else
RShiftByte = 0
End If
Exit Function
ElseIf bytShiftBits < 0 or bytShiftBits > 7 Then
Err.Raise 6
End If
RShiftByte = bytValue m_byt2Power(bytShiftBits)
End Function
Private Function RotateLeft(lValue, iShiftBits)
RotateLeft = LShift(lValue, iShiftBits) or RShift(lValue, (32 - iShiftBits))
End Function
Private Function RotateLeftByte(bytValue, bytShiftBits)
RotateLeftByte = LShiftByte(bytValue, bytShiftBits) or RShiftByte(bytValue, (8 - bytShiftBits))
End Function
Private Function Pack(b())
Dim lCount
Dim lTemp
For lCount = 0 To 3
lTemp = b(lCount)
Pack = Pack or LShift(lTemp, (lCount * 8))
Next
End Function
Private Function PackFrom(b(), k)
Dim lCount
Dim lTemp
For lCount = 0 To 3
lTemp = b(lCount + k)
PackFrom = PackFrom or LShift(lTemp, (lCount * 8))
Next
End Function
Private Sub Unpack(a, b())
b(0) = a And m_lOnBits(7)
b(1) = RShift(a, 8) And m_lOnBits(7)
b(2) = RShift(a, 16) And m_lOnBits(7)
b(3) = RShift(a, 24) And m_lOnBits(7)
End Sub
Private Sub UnpackFrom(a, b(), k)
b(0 + k) = a And m_lOnBits(7)
b(1 + k) = RShift(a, 8) And m_lOnBits(7)
b(2 + k) = RShift(a, 16) And m_lOnBits(7)
b(3 + k) = RShift(a, 24) And m_lOnBits(7)
End Sub
Private Function xtime(a)
Dim b
If (a And &H80) Then
b = &H1B
Else
b = 0
End If
xtime = LShiftByte(a, 1)
xtime = xtime Xor b
End Function
Private Function bmul(x, y)
If x <> 0 And y <> 0 Then
bmul = m_ptab((CLng(m_ltab(x)) + CLng(m_ltab(y))) Mod 255)
Else
bmul = 0
End If
End Function
Private Function SubByte(a)
Dim b(3)
Unpack a, 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)
End Function
Private Function product(x, y)
Dim xb(3)
Dim yb(3)
Unpack x, xb
Unpack y, yb
product = bmul(xb(0), yb(0)) Xor bmul(xb(1), yb(1)) Xor bmul(xb(2), yb(2)) Xor bmul(xb(3), yb(3))
End Function
Private Function InvMixCol(x)
Dim y
Dim m
Dim b(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
End Function
Private Function ByteSub(x)
Dim y
Dim z
z = x
y = m_ptab(255 - m_ltab(z))
z = y
z = RotateLeftByte(z, 1)
y = y Xor z
z = RotateLeftByte(z, 1)
y = y Xor z
z = RotateLeftByte(z, 1)
y = y Xor z
z = RotateLeftByte(z, 1)
y = y Xor z
y = y Xor &H63
ByteSub = y
End Function
Public Sub gentables()
Dim i
Dim y
Dim b(3)
Dim ib
m_ltab(0) = 0
m_ptab(0) = 1
m_ltab(1) = 0
m_ptab(1) = 3
m_ltab(3) = 1
For i = 2 To 255
m_ptab(i) = m_ptab(i - 1) Xor xtime(m_ptab(i - 1))
m_ltab(m_ptab(i)) = i
Next
m_fbsub(0) = &H63
m_rbsub(&H63) = 0
For i = 1 To 255
ib = i
y = ByteSub(ib)
m_fbsub(i) = y
m_rbsub(y) = i
Next
y = 1
For i = 0 To 29
m_rco(i) = y
y = xtime(y)
Next
For i = 0 To 255
y = m_fbsub(i)
b(3) = y Xor xtime(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
End Sub
Public Sub gkey(nb, nk, Key())
Dim i
Dim j
Dim k
Dim m
Dim N
Dim C1
Dim C2
Dim C3
Dim CipherKey(7)
m_Nb = nb
m_Nk = nk
If m_Nb >= m_Nk Then
m_Nr = 6 + m_Nb
Else
m_Nr = 6 + m_Nk
End If
C1 = 1
If m_Nb < 8 Then
C2 = 2
C3 = 3
Else
C2 = 3
C3 = 4
End If
For j = 0 To nb - 1
m = j * 3
m_fi(m) = (j + C1) Mod nb
m_fi(m + 1) = (j + C2) Mod nb
m_fi(m + 2) = (j + C3) Mod nb
m_ri(m) = (nb + j - C1) Mod nb
m_ri(m + 1) = (nb + j - C2) Mod nb
m_ri(m + 2) = (nb + j - C3) Mod nb
Next
N = m_Nb * (m_Nr + 1)
For i = 0 To m_Nk - 1
j = i * 4
CipherKey(i) = PackFrom(Key, j)
Next
For i = 0 To m_Nk - 1
m_fkey(i) = CipherKey(i)
Next
j = m_Nk
k = 0
Do While j < N
m_fkey(j) = m_fkey(j - m_Nk) Xor _
SubByte(RotateLeft(m_fkey(j - 1), 24)) Xor m_rco(k)
If m_Nk <= 6 Then
i = 1
Do While i < m_Nk And (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
Do While i < 4 And (i + j) < N
m_fkey(i + j) = m_fkey(i + j - m_Nk) Xor _
m_fkey(i + j - 1)
i = i + 1
Loop
If j + 4 < N Then
m_fkey(j + 4) = m_fkey(j + 4 - m_Nk) Xor _
SubByte(m_fkey(j + 3))
End If
i = 5
Do While i < m_Nk And (i + j) < N
m_fkey(i + j) = m_fkey(i + j - m_Nk) Xor _
m_fkey(i + j - 1)
i = i + 1
Loop
End If
j = j + m_Nk
k = k + 1
Loop
For j = 0 To m_Nb - 1
m_rkey(j + N - nb) = m_fkey(j)
Next
i = m_Nb
Do While i < N - m_Nb
k = N - m_Nb - i
For j = 0 To m_Nb - 1
m_rkey(k + j) = InvMixCol(m_fkey(i + j))
Next
i = i + m_Nb
Loop
j = N - m_Nb
Do While j < N
m_rkey(j - N + m_Nb) = m_fkey(j)
j = j + 1
Loop
End Sub
Public Sub encrypt(buff())
Dim i
Dim j
Dim k
Dim m
Dim a(7)
Dim b(7)
Dim x
Dim y
Dim t
For i = 0 To m_Nb - 1
j = i * 4
a(i) = PackFrom(buff, j)
a(i) = a(i) Xor m_fkey(i)
Next
k = m_Nb
x = a
y = b
For i = 1 To m_Nr - 1
For j = 0 To m_Nb - 1
m = j * 3
y(j) = m_fkey(k) Xor m_ftable(x(j) And m_lOnBits(7)) Xor _
RotateLeft(m_ftable(RShift(x(m_fi(m)), 8) And m_lOnBits(7)), 8) Xor _
RotateLeft(m_ftable(RShift(x(m_fi(m + 1)), 16) And m_lOnBits(7)), 16) Xor _
RotateLeft(m_ftable(RShift(x(m_fi(m + 2)), 24) And m_lOnBits(7)), 24)
k = k + 1
Next
t = x
x = y
y = t
Next
For j = 0 To m_Nb - 1
m = j * 3
y(j) = m_fkey(k) Xor m_fbsub(x(j) And m_lOnBits(7)) Xor _
RotateLeft(m_fbsub(RShift(x(m_fi(m)), 8) And m_lOnBits(7)), 8) Xor _
RotateLeft(m_fbsub(RShift(x(m_fi(m + 1)), 16) And m_lOnBits(7)), 16) Xor _
RotateLeft(m_fbsub(RShift(x(m_fi(m + 2)), 24) And m_lOnBits(7)), 24)
k = k + 1
Next
For i = 0 To m_Nb - 1
j = i * 4
UnpackFrom y(i), buff, j
x(i) = 0
y(i) = 0
Next
End Sub
Public Sub decrypt(buff())
Dim i
Dim j
Dim k
Dim m
Dim a(7)
Dim b(7)
Dim x
Dim y
Dim t
For i = 0 To m_Nb - 1
j = i * 4
a(i) = PackFrom(buff, j)
a(i) = a(i) Xor m_rkey(i)
Next
k = m_Nb
x = a
y = b
For i = 1 To m_Nr - 1
For j = 0 To m_Nb - 1
m = j * 3
y(j) = m_rkey(k) Xor m_rtable(x(j) And m_lOnBits(7)) Xor _
RotateLeft(m_rtable(RShift(x(m_ri(m)), 8) And m_lOnBits(7)), 8) Xor _
RotateLeft(m_rtable(RShift(x(m_ri(m + 1)), 16) And m_lOnBits(7)), 16) Xor _
RotateLeft(m_rtable(RShift(x(m_ri(m + 2)), 24) And m_lOnBits(7)), 24)
k = k + 1
Next
t = x
x = y
y = t
Next
For j = 0 To m_Nb - 1
m = j * 3
y(j) = m_rkey(k) Xor m_rbsub(x(j) And m_lOnBits(7)) Xor _
RotateLeft(m_rbsub(RShift(x(m_ri(m)), 8) And m_lOnBits(7)), 8) Xor _
RotateLeft(m_rbsub(RShift(x(m_ri(m + 1)), 16) And m_lOnBits(7)), 16) Xor _
RotateLeft(m_rbsub(RShift(x(m_ri(m + 2)), 24) And m_lOnBits(7)), 24)
k = k + 1
Next
For i = 0 To m_Nb - 1
j = i * 4
UnpackFrom y(i), buff, j
x(i) = 0
y(i) = 0
Next
End Sub
Private Function IsInitialized(vArray)
On Error Resume Next
IsInitialized = IsNumeric(UBound(vArray))
End Function
Private Sub CopyBytesASP(bytDest, lDestStart, bytSource(), lSourceStart, lLength)
Dim lCount
lCount = 0
Do
bytDest(lDestStart + lCount) = bytSource(lSourceStart + lCount)
lCount = lCount + 1
Loop Until lCount = lLength
End Sub
Public Function EncryptData(bytMessage, bytPassword)
Dim bytKey(31)
Dim bytIn()
Dim bytOut()
Dim bytTemp(31)
Dim lCount
Dim lLength
Dim lEncodedLength
Dim bytLen(3)
Dim lPosition
If Not IsInitialized(bytMessage) Then
Exit Function
End If
If Not IsInitialized(bytPassword) Then
Exit Function
End If
For lCount = 0 To UBound(bytPassword)
bytKey(lCount) = bytPassword(lCount)
If lCount = 31 Then
Exit For
End If
Next
gentables
gkey 8, 8, bytKey
lLength = UBound(bytMessage) + 1
lEncodedLength = lLength + 4
If lEncodedLength Mod 32 <> 0 Then
lEncodedLength = lEncodedLength + 32 - (lEncodedLength Mod 32)
End If
ReDim bytIn(lEncodedLength - 1)
ReDim bytOut(lEncodedLength - 1)
Unpack lLength, bytIn
CopyBytesASP bytIn, 4, bytMessage, 0, lLength
For lCount = 0 To lEncodedLength - 1 Step 32
CopyBytesASP bytTemp, 0, bytIn, lCount, 32
Encrypt bytTemp
CopyBytesASP bytOut, lCount, bytTemp, 0, 32
Next
EncryptData = bytOut
End Function
Public Function DecryptData(bytIn, bytPassword)
Dim bytMessage()
Dim bytKey(31)
Dim bytOut()
Dim bytTemp(31)
Dim lCount
Dim lLength
Dim lEncodedLength
Dim bytLen(3)
Dim lPosition
If Not IsInitialized(bytIn) Then
Exit Function
End If
If Not IsInitialized(bytPassword) Then
Exit Function
End If
lEncodedLength = UBound(bytIn) + 1
If lEncodedLength Mod 32 <> 0 Then
Exit Function
End If
For lCount = 0 To UBound(bytPassword)
bytKey(lCount) = bytPassword(lCount)
If lCount = 31 Then
Exit For
End If
Next
gentables
gkey 8, 8, bytKey
ReDim bytOut(lEncodedLength - 1)
For lCount = 0 To lEncodedLength - 1 Step 32
CopyBytesASP bytTemp, 0, bytIn, lCount, 32
Decrypt bytTemp
CopyBytesASP bytOut, lCount, bytTemp, 0, 32
Next
lLength = Pack(bytOut)
If lLength > lEncodedLength - 4 Then
Exit Function
End If
ReDim bytMessage(lLength - 1)
CopyBytesASP bytMessage, 0, bytOut, 4, lLength
DecryptData = bytMessage
End Function
8.一個(gè)日期轉(zhuǎn)換函數(shù)
Function FormatDate(byVal strDate, byVal strFormat)
' Accepts strDate as a valid date/time,
' strFormat as the output template.
' The function finds each item in the
' template and replaces it with the
' relevant information extracted from strDate.
' You are free to use this code provided the following line remains
' www.adopenstatic.com/resources/code/formatdate.asp
' Template items
' %m Month as a decimal no. 2
' %M Month as a padded decimal no. 02
' %B Full month name February
' %b Abbreviated month name Feb
' %d Day of the month eg 23
' %D Padded day of the month eg 09
' %O ordinal of day of month (eg st or rd or nd)
' %j Day of the year 54
' %Y Year with century 1998
' %y Year without century 98
' %w Weekday as integer (0 is Sunday)
' %a Abbreviated day name Fri
' %A Weekday Name Friday
' %H Hour in 24 hour format 24
' %h Hour in 12 hour format 12
' %N Minute as an integer 01
' %n Minute as optional if minute <> 00
' %S Second as an integer 55
' %P AM/PM Indicator PM
On Error Resume Next
Dim intPosItem
Dim int12HourPart
Dim str24HourPart
Dim strMinutePart
Dim strSecondPart
Dim strAMPM
' Insert Month Numbers
strFormat = Replace(strFormat, "%m", DatePart("m", strDate), 1, -1, vbBinaryCompare)
' Insert Padded Month Numbers
strFormat = Replace(strFormat, "%M", Right("0" & DatePart("m", strDate), 2), 1, -1, vbBinaryCompare)
' Insert non-Abbreviated Month Names
strFormat = Replace(strFormat, "%B", MonthName(DatePart("m", strDate), False), 1, -1, vbBinaryCompare)
' Insert Abbreviated Month Names
strFormat = Replace(strFormat, "%b", MonthName(DatePart("m", strDate), True), 1, -1, vbBinaryCompare)
' Insert Day Of Month
strFormat = Replace(strFormat, "%d", DatePart("d", strDate), 1, -1, vbBinaryCompare)
' Insert Padded Day Of Month
strFormat = Replace(strFormat, "%D", Right ("0" & DatePart("d", strDate), 2), 1, -1, vbBinaryCompare)
' Insert Day of Month ordinal (eg st, th, or rd)
strFormat = Replace(strFormat, "%O", GetDayOrdinal(Day(strDate)), 1, -1, vbBinaryCompare)
' Insert Day of Year
strFormat = Replace(strFormat, "%j", DatePart("y", strDate), 1, -1, vbBinaryCompare)
' Insert Long Year (4 digit)
strFormat = Replace(strFormat, "%Y", DatePart("yyyy", strDate), 1, -1, vbBinaryCompare)
' Insert Short Year (2 digit)
strFormat = Replace(strFormat, "%y", Right(DatePart("yyyy", strDate), 2), 1, -1, vbBinaryCompare)
' Insert Weekday as Integer (eg 0 = Sunday)
strFormat = Replace(strFormat, "%w", DatePart("w", strDate, 1), 1, -1, vbBinaryCompare)
' Insert Abbreviated Weekday Name (eg Sun)
strFormat = Replace(strFormat, "%a", WeekdayName(DatePart("w", strDate, 1), True), 1, -1, vbBinaryCompare)
' Insert non-Abbreviated Weekday Name
strFormat = Replace(strFormat, "%A", WeekdayName(DatePart("w", strDate, 1), False), 1, -1, vbBinaryCompare)
' Insert Hour in 24hr format
str24HourPart = DatePart("h", strDate)
If Len(str24HourPart) < 2 Then str24HourPart = "0" & str24HourPart
strFormat = Replace(strFormat, "%H", str24HourPart, 1, -1, vbBinaryCompare)
' Insert Hour in 12hr format
int12HourPart = DatePart("h", strDate) Mod 12
If int12HourPart = 0 Then int12HourPart = 12
strFormat = Replace(strFormat, "%h", int12HourPart, 1, -1, vbBinaryCompare)
' Insert Minutes
strMinutePart = DatePart("n", strDate)
If Len(strMinutePart) < 2 Then strMinutePart = "0" & strMinutePart
strFormat = Replace(strFormat, "%N", strMinutePart, 1, -1, vbBinaryCompare)
' Insert Optional Minutes
If CInt(strMinutePart) = 0 Then
strFormat = Replace(strFormat, "%n", "", 1, -1, vbBinaryCompare)
Else
If CInt(strMinutePart) < 10 Then strMinutePart = "0" & strMinutePart
strMinutePart = ":" & strMinutePart
strFormat = Replace(strFormat, "%n", strMinutePart, 1, -1, vbBinaryCompare)
End If
' Insert Seconds
strSecondPart = DatePart("s", strDate)
If Len(strSecondPart) < 2 Then strSecondPart = "0" & strSecondPart
strFormat = Replace(strFormat, "%S", strSecondPart, 1, -1, vbBinaryCompare)
' Insert AM/PM indicator
If DatePart("h", strDate) >= 12 Then
strAMPM = "PM"
Else
strAMPM = "AM"
End If
strFormat = Replace(strFormat, "%P", strAMPM, 1, -1, vbBinaryCompare)
FormatDate = strFormat
End Function
Function GetDayOrdinal( _
byVal intDay _
)
' Accepts a day of the month
' as an integer and returns the
' appropriate suffix
On Error Resume Next
Dim strOrd
Select Case intDay
Case 1, 21, 31
strOrd = "st"
Case 2, 22
strOrd = "nd"
Case 3, 23
strOrd = "rd"
Case Else
strOrd = "th"
End Select
GetDayOrdinal = strOrd
End Function
%>
<%
Dim db
db = "dbms.mdb"
'******************************************************************
'執(zhí)行sql語(yǔ)句，不返回值,sql語(yǔ)句最好是如下：
'update 表名 set 字段名=value,字段名=value where 字段名=value
'delete from 表名 where 字段名=value
'insert into 表名 (字段名,字段名) values (value,value)
'******************************************************************
Sub NoResult(sql)
Dim conn
Dim connstr
Set conn = Server.CreateObject("ADODB.Connection")
connstr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Server.MapPath(""&db&"")
conn.Open connstr
conn.Execute sql
conn.Close
Set conn = Nothing
End Sub
'*******************************************************************
'執(zhí)行select語(yǔ)句，返回recordset對(duì)象。該對(duì)象只讀。也就是不能更新
'*******************************************************************
Function Result(sql)
Dim conn
Dim connstr
Dim rcs
Set conn = Server.CreateObject("ADODB.Connection")
connstr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Server.MapPath(""&db&"")
conn.Open connstr
Set rcs = Server.CreateObject("ADODB.Recordset")
rcs.Open sql, conn, 1, 1
Set Result = rcs
End Function
'*******************************************************************
' 彈出對(duì)話框
'*******************************************************************
Sub alert(message)
message = Replace(message, "'", "\'")
Response.Write ("<script>alert('" & message & "')</script>")
End Sub
'*******************************************************************
' 返回上一頁(yè)，一般用在判斷信息提交是否完全之后
'*******************************************************************
Sub GoBack()
Response.Write ("<script>history.go(-1)</script>")
End Sub
'*******************************************************************
' 重定向另外的連接
'*******************************************************************
Sub Go(url)
Response.Write ("<script>location.href('" & url & "')</script>")
End Sub
'*******************************************************************
' 把html標(biāo)記替換
'*******************************************************************
Function htmlencode2(Str)
Dim result
Dim l
If IsNull(Str) Then
htmlencode2 = ""
Exit Function
End If
l = Len(Str)
result = ""
Dim i
For i = 1 To l
Select Case Mid(Str, i, 1)
Case "<"
result = result + "<"
Case ">"
result = result + ">"
Case Chr(13)
result = result + "<br>"
Case Chr(34)
result = result + """%>
<%
cLeft(String, Length) 返回指定數(shù)目的從字符串的左邊算起的字符，區(qū)分單雙字節(jié)。
如：
Dim MyString, LeftString
MyString = "文字測(cè)試VBSCript"
LeftString = cLeft(MyString, 10)
返回 "文字測(cè)試VB"。
MyRandc(n) 生成隨機(jī)字符，n為字符的個(gè)數(shù)
如：
response.Write MyRandn(10)
輸出10個(gè)隨機(jī)字符
MyRandn(n) 生成隨機(jī)數(shù)字，n為數(shù)字的個(gè)數(shù)
如：
response.Write MyRandn(10)
輸出10個(gè)隨機(jī)數(shù)字
formatQueryStr(Str) 格式化sql中的like字符串.
如：
q = Request("q")
q = formatQueryStr(q)
sql = "select * from [table] where aa like '%"& q &"%'"
GetRnd(min, max) 返回min - max之間的一個(gè)隨機(jī)數(shù)
如：
response.Write GetRnd(100, 200)
輸出大于100到200之間的一個(gè)隨機(jī)數(shù)
Function cLeft(Str, n)
Dim str1, str2, alln, Islefted
str2 = ""
alln = 0
str1 = Str
Islefted = False
If IsNull(Str) Then
cleft = ""
Exit Function
End If
For i = 1 To Len(str1)
nowstr = Mid(str1, i, 1)
If Asc(nowstr)<0 Then
alln = alln + 2
Else
alln = alln + 1
End If
If (alln<= n) Then
str2 = str2 & nowstr
Else
Islefted = True
Exit For
End If
Next
If Islefted Then
str2 = str2 & ".."
End If
cleft = str2
End Function
Function MyRandc(n) '生成隨機(jī)字符，n為字符的個(gè)數(shù)
Dim thechr
thechr = ""
For i = 1 To n
Dim zNum, zNum2
Randomize
zNum = CInt(25 * Rnd)
zNum2 = CInt(10 * Rnd)
If zNum2 Mod 2 = 0 Then
zNum = zNum + 97
Else
zNum = zNum + 65
End If
thechr = thechr & Chr(zNum)
Next
MyRandc = thechr
End Function
Function MyRandn(n) '生成隨機(jī)數(shù)字，n為數(shù)字的個(gè)數(shù)
Dim thechr
thechr = ""
For i = 1 To n
Dim zNum, zNum2
Randomize
zNum = CInt(9 * Rnd)
zNum = zNum + 48
thechr = thechr & Chr(zNum)
Next
MyRandn = thechr
End Function
Function formatQueryStr(Str) '格式化sql中的like字符串
Dim nstr
nstr = Str
nstr = Replace(nstr, Chr(0), "")
nstr = Replace(nstr, "'", "''")
nstr = Replace(nstr, "[", "[[]")
nstr = Replace(nstr, "%", "[%]")
formatQueryStr = nstr
End Function
Function GetRnd(min, max)
Randomize
GetRnd = Int((max - min + 1) * Rnd + min)
End Function
'*******************************************************************
'取得IP地址
'*******************************************************************
Function Userip()
Dim GetClientIP
'如果客戶端用了代理服務(wù)器，則應(yīng)該用ServerVariables("HTTP_X_FORWARDED_FOR")方法
GetClientIP = Request.ServerVariables("HTTP_X_FORWARDED_FOR")
If GetClientIP = "" or IsNull(GetClientIP) or IsEmpty(GetClientIP) Then
'如果客戶端沒用代理，應(yīng)該用Request.ServerVariables("REMOTE_ADDR")方法
GetClientIP = Request.ServerVariables("REMOTE_ADDR")
End If
Userip = GetClientIP
End Function
'*******************************************************************
'轉(zhuǎn)換IP地址
'*******************************************************************
Function cip(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)
End Function
'*******************************************************************
' 彈出對(duì)話框
'*******************************************************************
Sub alert(message)
message = Replace(message, "'", "\'")
Response.Write ("<script>alert('" & message & "')</script>")
End Sub
'*******************************************************************
' 返回上一頁(yè)，一般用在判斷信息提交是否完全之后
'*******************************************************************
Sub GoBack()
Response.Write ("<script>history.go(-1)</script>")
End Sub
'*******************************************************************
' 重定向另外的連接
'*******************************************************************
Sub Go(url)
Response.Write ("<script>location.href('" & url & "')</script>")
End Sub
'*******************************************************************
' 指定秒數(shù)重定向另外的連接
'*******************************************************************
Sub GoPage(url, s)
s = s * 1000
Response.Write "<SCRIPT LANGUAGE=javascript>"
Response.Write "window.setTimeout("&Chr(34)&"window.navigate('"&url&"')"&Chr(34)&","&s&")"
Response.Write "</script>"
End Sub
'*******************************************************************
' 判斷數(shù)字是否整形
'*******************************************************************
Function isInteger(para)
On Error Resume Next
Dim Str
Dim l, i
If IsNull(para) Then
isInteger = False
Exit Function
End If
Str = CStr(para)
If Trim(Str) = "" Then
isInteger = False
Exit Function
End If
l = Len(Str)
For i = 1 To l
If Mid(Str, i, 1)>"9" or Mid(Str, i, 1)<"0" Then
isInteger = False
Exit Function
End If
Next
isInteger = True
If Err.Number<>0 Then Err.Clear
End Function
'*******************************************************************
' 獲得文件擴(kuò)展名
'*******************************************************************
Function GetExtend(filename)
Dim tmp
If filename<>"" Then
tmp = Mid(filename, instrrev(filename, ".") + 1, Len(filename) - instrrev(filename, "."))
tmp = LCase(tmp)
If InStr(1, tmp, "asp")>0 or InStr(1, tmp, "php")>0 or InStr(1, tmp, "php3")>0 or InStr(1, tmp, "aspx")>0 Then
getextend = "txt"
Else
getextend = tmp
End If
Else
getextend = ""
End If
End Function
' *----------------------------------------------------------------------------
' * 函數(shù)：CheckIn
' * 描述：檢測(cè)參數(shù)是否有SQL危險(xiǎn)字符
' * 參數(shù)：str要檢測(cè)的數(shù)據(jù)
' * 返回：FALSE：安全 TRUE：不安全
' * 作者：
' * 日期：
' *----------------------------------------------------------------------------
Function CheckIn(Str)
If InStr(1, Str, Chr(39))>0 or InStr(1, Str, Chr(34))>0 or InStr(1, Str, Chr(59))>0 Then
CheckIn = True
Else
CheckIn = False
End If
End Function
' *----------------------------------------------------------------------------
' * 函數(shù)：HTMLEncode
' * 描述：過(guò)濾HTML代碼
' * 參數(shù)：--
' * 返回：--
' * 作者：
' * 日期：
' *----------------------------------------------------------------------------
Function HTMLEncode(fString)
If Not IsNull(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
End If
End Function
' *----------------------------------------------------------------------------
' * 函數(shù)：HTMLcode
' * 描述：過(guò)濾表單字符
' * 參數(shù)：--
' * 返回：--
' * 作者：
' * 日期：
' *----------------------------------------------------------------------------
Function HTMLcode(fString)
If Not IsNull(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
End If
End Function
%>
<%
cLeft(String, Length) 返回指定數(shù)目的從字符串的左邊算起的字符，區(qū)分單雙字節(jié)。
如：
Dim MyString, LeftString
MyString = "文字測(cè)試VBSCript"
LeftString = cLeft(MyString, 10)
返回 "文字測(cè)試VB"。
MyRandc(n) 生成隨機(jī)字符，n為字符的個(gè)數(shù)
如：
response.Write MyRandn(10)
輸出10個(gè)隨機(jī)字符
MyRandn(n) 生成隨機(jī)數(shù)字，n為數(shù)字的個(gè)數(shù)
如：
response.Write MyRandn(10)
輸出10個(gè)隨機(jī)數(shù)字
formatQueryStr(Str) 格式化sql中的like字符串.
如：
q = Request("q")
q = formatQueryStr(q)
sql = "select * from [table] where aa like '%"& q &"%'"
GetRnd(min, max) 返回min - max之間的一個(gè)隨機(jī)數(shù)
如：
response.Write GetRnd(100, 200)
輸出大于100到200之間的一個(gè)隨機(jī)數(shù)
Function cLeft(Str, n)
Dim str1, str2, alln, Islefted
str2 = ""
alln = 0
str1 = Str
Islefted = False
If IsNull(Str) Then
cleft = ""
Exit Function
End If
For i = 1 To Len(str1)
nowstr = Mid(str1, i, 1)
If Asc(nowstr)<0 Then
alln = alln + 2
Else
alln = alln + 1
End If
If (alln<= n) Then
str2 = str2 & nowstr
Else
Islefted = True
Exit For
End If
Next
If Islefted Then
str2 = str2 & ".."
End If
cleft = str2
End Function
Function MyRandc(n) '生成隨機(jī)字符，n為字符的個(gè)數(shù)
Dim thechr
thechr = ""
For i = 1 To n
Dim zNum, zNum2
Randomize
zNum = CInt(25 * Rnd)
zNum2 = CInt(10 * Rnd)
If zNum2 Mod 2 = 0 Then
zNum = zNum + 97
Else
zNum = zNum + 65
End If
thechr = thechr & Chr(zNum)
Next
MyRandc = thechr
End Function
Function MyRandn(n) '生成隨機(jī)數(shù)字，n為數(shù)字的個(gè)數(shù)
Dim thechr
thechr = ""
For i = 1 To n
Dim zNum, zNum2
Randomize
zNum = CInt(9 * Rnd)
zNum = zNum + 48
thechr = thechr & Chr(zNum)
Next
MyRandn = thechr
End Function
Function formatQueryStr(Str) '格式化sql中的like字符串
Dim nstr
nstr = Str
nstr = Replace(nstr, Chr(0), "")
nstr = Replace(nstr, "'", "''")
nstr = Replace(nstr, "[", "[[]")
nstr = Replace(nstr, "%", "[%]")
formatQueryStr = nstr
End Function
Function GetRnd(min, max)
Randomize
GetRnd = Int((max - min + 1) * Rnd + min)
End Function
'*******************************************************************
'取得IP地址
'*******************************************************************
Function Userip()
Dim GetClientIP
'如果客戶端用了代理服務(wù)器，則應(yīng)該用ServerVariables("HTTP_X_FORWARDED_FOR")方法
GetClientIP = Request.ServerVariables("HTTP_X_FORWARDED_FOR")
If GetClientIP = "" or IsNull(GetClientIP) or IsEmpty(GetClientIP) Then
'如果客戶端沒用代理，應(yīng)該用Request.ServerVariables("REMOTE_ADDR")方法
GetClientIP = Request.ServerVariables("REMOTE_ADDR")
End If
Userip = GetClientIP
End Function
'*******************************************************************
'轉(zhuǎn)換IP地址
'*******************************************************************
Function cip(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)
End Function
'*******************************************************************
' 彈出對(duì)話框
'*******************************************************************
Sub alert(message)
message = Replace(message, "'", "\'")
Response.Write ("<script>alert('" & message & "')</script>")
End Sub
'*******************************************************************
' 返回上一頁(yè)，一般用在判斷信息提交是否完全之后
'*******************************************************************
Sub GoBack()
Response.Write ("<script>history.go(-1)</script>")
End Sub
'*******************************************************************
' 重定向另外的連接
'*******************************************************************
Sub Go(url)
Response.Write ("<script>location.href('" & url & "')</script>")
End Sub
'*******************************************************************
' 指定秒數(shù)重定向另外的連接
'*******************************************************************
Sub GoPage(url, s)
s = s * 1000
Response.Write "<SCRIPT LANGUAGE=javascript>"
Response.Write "window.setTimeout("&Chr(34)&"window.navigate('"&url&"')"&Chr(34)&","&s&")"
Response.Write "</script>"
End Sub
'*******************************************************************
' 判斷數(shù)字是否整形
'*******************************************************************
Function isInteger(para)
On Error Resume Next
Dim Str
Dim l, i
If IsNull(para) Then
isInteger = False
Exit Function
End If
Str = CStr(para)
If Trim(Str) = "" Then
isInteger = False
Exit Function
End If
l = Len(Str)
For i = 1 To l
If Mid(Str, i, 1)>"9" or Mid(Str, i, 1)<"0" Then
isInteger = False
Exit Function
End If
Next
isInteger = True
If Err.Number<>0 Then Err.Clear
End Function
'*******************************************************************
' 獲得文件擴(kuò)展名
'*******************************************************************
Function GetExtend(filename)
Dim tmp
If filename<>"" Then
tmp = Mid(filename, instrrev(filename, ".") + 1, Len(filename) - instrrev(filename, "."))
tmp = LCase(tmp)
If InStr(1, tmp, "asp")>0 or InStr(1, tmp, "php")>0 or InStr(1, tmp, "php3")>0 or InStr(1, tmp, "aspx")>0 Then
getextend = "txt"
Else
getextend = tmp
End If
Else
getextend = ""
End If
End Function
' *----------------------------------------------------------------------------
' * 函數(shù)：CheckIn
' * 描述：檢測(cè)參數(shù)是否有SQL危險(xiǎn)字符
' * 參數(shù)：str要檢測(cè)的數(shù)據(jù)
' * 返回：FALSE：安全 TRUE：不安全
' * 作者：
' * 日期：
' *----------------------------------------------------------------------------
Function CheckIn(Str)
If InStr(1, Str, Chr(39))>0 or InStr(1, Str, Chr(34))>0 or InStr(1, Str, Chr(59))>0 Then
CheckIn = True
Else
CheckIn = False
End If
End Function
' *----------------------------------------------------------------------------
' * 函數(shù)：HTMLEncode
' * 描述：過(guò)濾HTML代碼
' * 參數(shù)：--
' * 返回：--
' * 作者：
' * 日期：
' *----------------------------------------------------------------------------
Function HTMLEncode(fString)
If Not IsNull(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
End If
End Function
' *----------------------------------------------------------------------------
' * 函數(shù)：HTMLcode
' * 描述：過(guò)濾表單字符
' * 參數(shù)：--
' * 返回：--
' * 作者：
' * 日期：
' *----------------------------------------------------------------------------
Function HTMLcode(fString)
If Not IsNull(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
End If
End Function
%>
11.ACCESS數(shù)據(jù)庫(kù)連接:
<%
Option Explicit
Dim startime, endtime, conn, connstr, db
startime = Timer()
'更改數(shù)據(jù)庫(kù)名字
db = "data/dvBBS5.mdb"
Set conn = Server.CreateObject("ADODB.Connection")
connstr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Server.MapPath(db)
'如果你的服務(wù)器采用較老版本Access驅(qū)動(dòng)，請(qǐng)用下面連接方法
'connstr="driver={Microsoft Access Driver (*.mdb)};dbq=" & Server.MapPath(db)
conn.Open connstr
Function CloseDatabase
Conn.Close
Set conn = Nothing
End Function
%>
12.SQL數(shù)據(jù)庫(kù)連接:
<%
Option Explicit
Dim startime, endtime, conn, connstr, db
startime = Timer()
connstr = "driver={SQL Server};server=HUDENQ-N11T33NB;uid=sa;pwd=xsfeihu;database=dvbbs"
Set conn = Server.CreateObject("ADODB.Connection")
conn.Open connstr
Function CloseDatabase
Conn.Close
Set conn = Nothing
End Function
%>
13.用鍵盤打開網(wǎng)頁(yè)代碼:
<script language="javascript">
function ctlent(eventobject)
{
if((event.ctrlKey && window.event.keyCode==13)||(event.altKey && window.event.keyCode==83))
{
window.open('網(wǎng)址','','')
}
}
</script>
這里是Ctrl+Enter和Alt+S的代碼 自己查下鍵盤的ASCII碼再換就行
14.讓層不被控件復(fù)蓋代碼:
<div z-Index:2><object ***></object></div> ＃ 前面
<div z-Index:1><object ***></object></div> ＃ 后面
<div id="Layer2" style="position:absolute; top:40;width:400px; height:95px;z-index:2"><table height=100% width=100% bgcolor="#ff0000"><tr><td height=100% width=100%></td></tr></table><iframe width=0 height=0></iframe></div>
<div id="Layer1" style="position:absolute; top:50;width:200px; height:115px;z-index:1"><iframe height=100% width=100%></iframe></div>
15.動(dòng)網(wǎng)FLASH廣告代碼:
<object classid="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"><param name=movie value="images/yj16d.swf"><param name=quality value=high><embed src="images/dvbanner.swf" quality=high pluginspage="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彈出窗口小代碼:
<script language=vbscript>
msgbox"你還沒有注冊(cè)或登陸論壇","0","精品論壇"
location.href = "login.asp"
</script>
16.使用FSO修改文件特定內(nèi)容的函數(shù)
<%
Function FSOchange(filename, Target, String)
Dim objFSO, objCountFile, FiletempData
Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
Set objCountFile = objFSO.OpenTextFile(Server.MapPath(filename), 1, True)
FiletempData = objCountFile.ReadAll
objCountFile.Close
FiletempData = Replace(FiletempData, Target, String)
Set objCountFile = objFSO.CreateTextFile(Server.MapPath(filename), True)
objCountFile.Write FiletempData
objCountFile.Close
Set objCountFile = Nothing
Set objFSO = Nothing
End Function
%>
17.使用FSO讀取文件內(nèi)容的函數(shù)
<%
Function FSOFileRead(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
%>
18.使用FSO讀取文件某一行的函數(shù)
<%
Function FSOlinedit(filename, lineNum)
If linenum < 1 Then Exit Function
Dim fso, f, temparray, tempcnt
Set fso = server.CreateObject("scripting.filesystemobject")
If Not fso.FileExists(server.mappath(filename)) Then Exit Function
Set f = fso.OpenTextFile(server.mappath(filename), 1)
If Not f.AtEndOfStream Then
tempcnt = f.ReadAll
f.Close
Set f = Nothing
temparray = Split(tempcnt, Chr(13)&Chr(10))
If lineNum>UBound(temparray) + 1 Then
Exit Function
Else
FSOlinedit = temparray(lineNum -1)
End If
End If
End Function
%>
19.使用FSO寫文件某一行的函數(shù)
<%
Function FSOlinewrite(filename, lineNum, Linecontent)
If linenum < 1 Then Exit Function
Dim fso, f, temparray, tempCnt
Set fso = server.CreateObject("scripting.filesystemobject")
If Not fso.FileExists(server.mappath(filename)) Then Exit Function
Set f = fso.OpenTextFile(server.mappath(filename), 1)
If Not f.AtEndOfStream Then
tempcnt = f.ReadAll
f.Close
temparray = Split(tempcnt, Chr(13)&Chr(10))
If lineNum>UBound(temparray) + 1 Then
Exit Function
Else
temparray(lineNum -1) = lineContent
End If
tempcnt = Join(temparray, Chr(13)&Chr(10))
Set f = fso.CreateTextFile(server.mappath(filename), True)
f.Write tempcnt
End If
f.Close
Set f = Nothing
End Function
%>
20.使用FSO添加文件新行的函數(shù)
<%
Function FSOappline(filename, Linecontent)
Dim fso, f
Set fso = server.CreateObject("scripting.filesystemobject")
If Not fso.FileExists(server.mappath(filename)) Then Exit Function
Set f = fso.OpenTextFile(server.mappath(filename), 8, 1)
f.Write Chr(13)&Chr(10)&Linecontent
f.Close
Set f = Nothing
End Function
%>
21.讀文件最后一行的函數(shù)
<%
Function FSOlastline(filename)
Dim fso, f, temparray, tempcnt
Set fso = server.CreateObject("scripting.filesystemobject")
If Not fso.FileExists(server.mappath(filename)) Then Exit Function
Set f = fso.OpenTextFile(server.mappath(filename), 1)
If Not f.AtEndOfStream Then
tempcnt = f.ReadAll
f.Close
Set f = Nothing
temparray = Split(tempcnt, Chr(13)&Chr(10))
FSOlastline = temparray(UBound(temparray))
End If
End Function
%>
利用FSO取得BMP，JPG，PNG，GIF文件信息(大小，寬、高等)
<%
'::: BMP, GIF, JPG and PNG :::
'::: This function gets a specified number of bytes from any :::
'::: file, starting at the offset (base 1) :::
'::: :::
'::: Passed: :::
'::: flnm => Filespec of file to read :::
'::: offset => Offset at which to start reading :::
'::: bytes => How many bytes to read :::
'::: :::
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
Function GetBytes(flnm, offset, bytes)
Dim objFSO
Dim objFTemp
Dim objTextStream
Dim lngSize
On Error Resume Next
Set objFSO = CreateObject("Scripting.FileSystemObject")
' First, we get the filesize
Set objFTemp = objFSO.GetFile(flnm)
lngSize = objFTemp.Size
Set objFTemp = Nothing
fsoForReading = 1
Set objTextStream = objFSO.OpenTextFile(flnm, fsoForReading)
If offset > 0 Then
strBuff = objTextStream.Read(offset - 1)
End If
If bytes = -1 Then ' Get All!
GetBytes = objTextStream.Read(lngSize) 'ReadAll
Else
GetBytes = objTextStream.Read(bytes)
End If
objTextStream.Close
Set objTextStream = Nothing
Set objFSO = Nothing
End Function
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
'::: :::
'::: Functions to convert two bytes to a numeric value (long) :::
'::: (both little-endian and big-endian) :::
'::: :::
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
Function lngConvert(strTemp)
lngConvert = CLng(Asc(Left(strTemp, 1)) + ((Asc(Right(strTemp, 1)) * 256)))
End Function
Function lngConvert2(strTemp)
lngConvert2 = CLng(Asc(Right(strTemp, 1)) + ((Asc(Left(strTemp, 1)) * 256)))
End Function
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
'::: :::
'::: This function does most of the real work. It will attempt :::
'::: to read any file, regardless of the extension, and will :::
'::: identify if it is a graphical image. :::
'::: :::
'::: Passed: :::
'::: flnm => Filespec of file to read :::
'::: width => width of image :::
'::: height => height of image :::
'::: depth => color depth (in number of colors) :::
'::: strImageType=> type of image (e.g. GIF, BMP, etc.) :::
'::: :::
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
Function gfxSpex(flnm, Width, height, depth, strImageType)
Dim strPNG
Dim strGIF
Dim strBMP
Dim strType
strType = ""
strImageType = "(unknown)"
gfxSpex = False
strPNG = Chr(137) & Chr(80) & Chr(78)
strGIF = "GIF"
strBMP = Chr(66) & Chr(77)
strType = GetBytes(flnm, 0, 3)
If strType = strGIF Then ' is GIF
strImageType = "GIF"
Width = lngConvert(GetBytes(flnm, 7, 2))
Height = lngConvert(GetBytes(flnm, 9, 2))
Depth = 2 ^ ((Asc(GetBytes(flnm, 11, 1)) And 7) + 1)
gfxSpex = True
ElseIf Left(strType, 2) = strBMP Then ' is BMP
strImageType = "BMP"
Width = lngConvert(GetBytes(flnm, 19, 2))
Height = lngConvert(GetBytes(flnm, 23, 2))
Depth = 2 ^ (Asc(GetBytes(flnm, 29, 1)))
gfxSpex = True
ElseIf strType = strPNG Then ' Is PNG
strImageType = "PNG"
Width = lngConvert2(GetBytes(flnm, 19, 2))
Height = lngConvert2(GetBytes(flnm, 23, 2))
Depth = getBytes(flnm, 25, 2)
Select Case Asc(Right(Depth, 1))
Case 0
Depth = 2 ^ (Asc(Left(Depth, 1)))
gfxSpex = True
Case 2
Depth = 2 ^ (Asc(Left(Depth, 1)) * 3)
gfxSpex = True
Case 3
Depth = 2 ^ (Asc(Left(Depth, 1))) '8
gfxSpex = True
Case 4
Depth = 2 ^ (Asc(Left(Depth, 1)) * 2)
gfxSpex = True
Case 6
Depth = 2 ^ (Asc(Left(Depth, 1)) * 4)
gfxSpex = True
Case Else
Depth = -1
End Select
Else
strBuff = GetBytes(flnm, 0, -1) ' Get all bytes from file
lngSize = Len(strBuff)
flgFound = 0
strTarget = Chr(255) & Chr(216) & Chr(255)
flgFound = InStr(strBuff, strTarget)
If flgFound = 0 Then
Exit Function
End If
strImageType = "JPG"
lngPos = flgFound + 2
ExitLoop = False
Do While ExitLoop = False And lngPos < lngSize
Do While Asc(Mid(strBuff, lngPos, 1)) = 255 And lngPos < lngSize
lngPos = lngPos + 1
Loop
If Asc(Mid(strBuff, lngPos, 1)) < 192 or Asc(Mid(strBuff, lngPos, 1)) > 195 Then
lngMarkerSize = lngConvert2(Mid(strBuff, lngPos + 1, 2))
lngPos = lngPos + lngMarkerSize + 1
Else
ExitLoop = True
End If
Loop
'
If ExitLoop = False Then
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
End If
End If
End Function
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
'::: Test Harness :::
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
' To test, we'll just try to show all files with a .GIF extension in the root of C:
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objF = objFSO.GetFolder("c:\")
Set objFC = objF.Files
response.Write "<table border=""0"" cellpadding=""5"">"
For Each f1 in objFC
If InStr(UCase(f1.Name), ".GIF") Then
response.Write "<tr><td>" & f1.Name & "</td><td>" & f1.DateCreated & "</td><td>" & f1.Size & "</td><td>"
If gfxSpex(f1.Path, w, h, c, strType) = True Then
response.Write w & " x " & h & " " & c & " colors"
Else
response.Write " "
End If
response.Write "</td></tr>"
End If
Next
response.Write "</table>"
Set objFC = Nothing
Set objF = Nothing
Set objFSO = Nothing
%>
24.點(diǎn)擊返回上頁(yè)代碼:
<form>
<p><input TYPE="button" value="返回上一步" onCLICK="history.back(-1)"></p>
</form>
24.點(diǎn)擊刷新代碼:
<form>
<p><input TYPE="button" value="刷新按鈕一" onCLICK="ReloadButton()"></p>
</form>
<script language="javascript"><!--
function ReloadButton(){location.href="allbutton.htm";}
// --></script>
24.點(diǎn)擊刷新代碼2:
<form>
<p><input TYPE="button" value="刷新按鈕二" onClick="history.go(0)"> </p>
</form>
<form>
<p><input TYPE="button" value="打開一個(gè)網(wǎng)站" onCLICK="HomeButton()"></p>
</form>
<script language="javascript"><!--
function HomeButton(){location.;;;}
// --></script>
25.彈出警告框代碼:
<form>
<p><input TYPE="button" value="彈出警告框" onCLICK="AlertButton()"></p>
</form>
<script language="javascript"><!--
function AlertButton(){window.alert("要多多光臨呀！");}
// --></script>
26.狀態(tài)欄信息
<form>
<p><input TYPE="button" value="狀態(tài)欄信息" onCLICK="StatusButton()"></p>
</form>
<script language="javascript"><!--
function StatusButton(){window.status="要多多光臨呀！";}
// --></script>
27.背景色變換
<form>
<p><input TYPE="button" value="背景色變換" onClick="BgButton()"></p>
</form>
<script>function BgButton(){
if (document.bgColor=='#00ffff')
{document.bgColor='#ffffff';}
else{document.bgColor='#00ffff';}
}
</script>
28.點(diǎn)擊打開新窗口
<form>
<p><input TYPE="button" value="打開新窗口" onCLICK="NewWindow()"></p>
</form>
<script language="javascript"><!--
function NewWindow(){window.open("http://www.mcmx.com";;,"","height=240,width=340,status=no,location=no,toolbar=no,directories=no,menubar=no");}
// --></script></body>
29.分頁(yè)代碼:
<%''本程序文件名為：Pages.asp%>
<%''包含ADO常量表文件adovbs.inc，可從"\Program Files\Common Files\System\ADO"目錄下拷貝%>
<!--#Include File="adovbs.inc"-->
<%''＊建立數(shù)據(jù)庫(kù)連接，這里是Oracle8.05數(shù)據(jù)庫(kù)
Set conn = Server.CreateObject("ADODB.Connection")
conn.Open "Provider=msdaora.1;Data Source=YourSrcName;User ID=YourUserID;Password=YourPassword;"
Set rs = Server.CreateObject("ADODB.Recordset") ''創(chuàng)建Recordset對(duì)象
rs.CursorLocation = adUseClient ''設(shè)定記錄集指針屬性
''＊設(shè)定一頁(yè)內(nèi)的記錄總數(shù)，可根據(jù)需要進(jìn)行調(diào)整
rs.PageSize = 10
''＊設(shè)置查詢語(yǔ)句
StrSQL = "Select ID,姓名,住址,電話 from 通訊錄 order By ID"
rs.Open StrSQL, conn, adOpenStatic, adLockReadOnly, adCmdText
%>
<HTML>
<HEAD>
<title>分頁(yè)示例</title>
<script language=javascript>
//點(diǎn)擊"[第一頁(yè)]"時(shí)響應(yīng)：
function PageFirst()
{
document.MyForm.CurrentPage.selectedIndex=0;
document.MyForm.CurrentPage.onchange();
}
//點(diǎn)擊"[上一頁(yè)]"時(shí)響應(yīng)：
function PagePrior()
{
document.MyForm.CurrentPage.selectedIndex--;
document.MyForm.CurrentPage.onchange();
}
//點(diǎn)擊"[下一頁(yè)]"時(shí)響應(yīng)：
function PageNext()
{
document.MyForm.CurrentPage.selectedIndex++;
document.MyForm.CurrentPage.onchange();
}
//點(diǎn)擊"[最后一頁(yè)]"時(shí)響應(yīng)：
function PageLast()
{
document.MyForm.CurrentPage.selectedIndex=document.MyForm.CurrentPage.length-1;
document.MyForm.CurrentPage.onchange();
}
//選擇"第？頁(yè)"時(shí)響應(yīng)：
function PageCurrent()
{ //Pages.asp是本程序的文件名
document.MyForm.action='Pages.asp?Page='+(document.MyForm.CurrentPage.selectedIndex+1)
document.MyForm.submit();
}
</Script>
</HEAD>
<BODY bgcolor="#ffffcc" link="#008000" vlink="#008000" alink="#FF0000"">
<%
If rs.EOF Then
Response.Write("<font size=2 color=#000080>[數(shù)據(jù)庫(kù)中沒有記錄！]</font>")
Else
''指定當(dāng)前頁(yè)碼
If Request("CurrentPage") = "" Then
rs.AbsolutePage = 1
Else
rs.AbsolutePage = CLng(Request("CurrentPage"))
End If
''創(chuàng)建表單MyForm,方法為Get
Response.Write("<form method=Get name=MyForm>")
Response.Write("<p align=center><font size=2 color=#008000>")
''設(shè)置翻頁(yè)超鏈接
If rs.PageCount = 1 Then
Response.Write("[第一頁(yè)] [上一頁(yè)] [下一頁(yè)] [最后一頁(yè)] ")
Else
If rs.AbsolutePage = 1 Then
Response.Write("[第一頁(yè)] [上一頁(yè)] ")
Response.Write("[<a href=java script:PageNext()>下一頁(yè)</a>] ")
Response.Write("[<a href=java script:PageLast()>最后一頁(yè)</a>] ")
Else
If rs.AbsolutePage = rs.PageCount Then
Response.Write("[<a href=java script:PageFirst()>第一頁(yè)</a>] ")
Response.Write("[<a href=java script:PagePrior()>上一頁(yè)</a>] ")
Response.Write("[下一頁(yè)] [最后一頁(yè)] ")
Else
Response.Write("[<a href=java script:PageFirst()>第一頁(yè)</a>] ")
Response.Write("[<a href=java script:PagePrior()>上一頁(yè)</a>] ")
Response.Write("[<a href=java script:PageNext()>下一頁(yè)</a>] ")
Response.Write("[<a href=java script:PageLast()>最后一頁(yè)</a>] ")
End If
End If
End If
''創(chuàng)建下拉列表框，用于選擇瀏覽頁(yè)碼
Response.Write("第<select size=1 name=CurrentPage onchange=PageCurrent()>")
For i = 1 To rs.PageCount
If rs.AbsolutePage = i Then
Response.Write("<option selected>"&i&"</option>") ''當(dāng)前頁(yè)碼
Else
Response.Write("<option>"&i&"</option>")
End If
Next
Response.Write("</select>頁(yè)/共"&rs.PageCount&"頁(yè) 共"&rs.RecordCount&"條記錄</font><p>")
Response.Write("</form>")
''創(chuàng)建表格，用于顯示
Response.Write("<table align=center cellspacing=1 cellpadding=1 border=1")
Response.Write(" bordercolor=#99CCFF bordercolordark=#b0e0e6 bordercolorlight=#000066>")
Response.Write("<tr bgcolor=#ccccff bordercolor=#000066>")
Set Columns = rs.Fields
''顯示表頭
For i = 0 To Columns.Count -1
Response.Write("<td align=center width=200 height=13>")
Response.Write("<font size=2><b>"&Columns(i).Name&"</b></font></td>")
Next
Response.Write("</tr>")
''顯示內(nèi)容
For i = 1 To rs.PageSize
Response.Write("<tr bgcolor=#99ccff bordercolor=#000066>")
For j = 0 To Columns.Count -1
Response.Write("<td><font size=2>"&Columns(j)&"</font></td>")
Next
Response.Write("</tr>")
rs.movenext
If rs.EOF Then Exit For
Next
Response.Write("</table>")
End If
%>
</BODY>
</HTML>
<%
Rem - - - 表單提示函數(shù) Being - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
CODE Copy ...
Function Check_submit(Str, restr)
If Str = "" Then
response.Write "<script>"
response.Write "alert(‘'"&restr&"‘');"
response.Write "history.go(-1)"
response.Write "</script>"
response.End
Else
Check_submit = Str
End If
End Function
CODE Copy ...
Function Alert_submit(Str)
response.Write "<script>"
response.Write "alert(‘'"&Str&"‘');"
‘'response.Write "location.reload();"
response.Write "</script>"
End Function
CODE Copy ...
Function localhost_submit(Str, urls)
response.Write "<script>"
If Str<>"" Then
response.Write "alert(‘'"&Str&"‘');"
End If
response.Write "location=‘'"&urls&"‘';"
response.Write "</script>"
End Function
Rem - - - 生成自定義位隨機(jī)數(shù) Being - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
CODE Copy ...
Function makerndid(byVal maxLen)
Dim strNewPass
Dim whatsNext, upper, lower, intCounter
Randomize
For intCounter = 1 To maxLen
whatsNext = Int(2 * Rnd)
If whatsNext = 0 Then
upper = 80
lower = 70
Else
upper = 48
lower = 39
End If
strNewPass = strNewPass & Chr(Int((upper - lower + 1) * Rnd + upper))
Next
makerndid = strNewPass
End Function
Rem - - - 生成四位隨機(jī)數(shù) Being - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
CODE Copy ...
Function get_rand()
Dim num1
Dim rndnum
Randomize
Do While Len(rndnum)<4
num1 = CStr(Chr((57 -48) * Rnd + 48))
rndnum = rndnum&num1
Loop
get_rand = rndnum
End Function
Rem - - - 判斷數(shù)據(jù)是否整型 Being - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
CODE Copy ...
Function IsInteger(para)
On Error Resume Next
Dim Str
Dim l, i
If IsNull(para) Then
isInteger = False
Exit Function
End If
Str = CStr(para)
If Trim(Str) = "" Then
isInteger = False
Exit Function
End If
l = Len(Str)
For i = 1 To l
If Mid(Str, i, 1)>"9" or Mid(Str, i, 1)<"0" Then
isInteger = False
Exit Function
End If
Next
isInteger = True
If Err.Number<>0 Then Err.Clear
End Function
Rem - - - 數(shù)據(jù)庫(kù)鏈接函數(shù) Being - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
CODE Copy ...
Function OpenCONN
Set conn = Server.CreateObject("ADODB.Connection")
connstr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Server.MapPath(DB_login)
conn.Open connstr
End Function
Rem - - - 中文字符轉(zhuǎn)Uncode代碼函數(shù) Being - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
CODE Copy ...
Function URLEncoding(vstrIn)
strReturn = ""
For i = 1 To Len(vstrIn)
ThisChr = Mid(vStrIn, i, 1)
If Abs(Asc(ThisChr)) < &HFF Then
strReturn = strReturn & ThisChr
Else
innerCode = Asc(ThisChr)
If innerCode < 0 Then
innerCode = innerCode + &H10000
End If
Hight8 = (innerCode And &HFF00) \ &HFF
Low8 = innerCode And &HFF
strReturn = strReturn & "%" & Hex(Hight8) & "%" & Hex(Low8)
End If
Next
URLEncoding = strReturn
End Function
Rem - - - Html過(guò)濾函數(shù) Being - - - - - - - - - - - - - - - - - - - - - - - - - - - - - Function Htmlout(Str)
CODE Copy ...
Dim result
Dim l
If IsNull(Str) Then
Htmlout = ""
Exit Function
End If
l = Len(Str)
result = ""
Dim i
For i = 1 To l
Select Case Mid(Str, i, 1)
Case "<"
result = result + "<"
Case ">"
result = result + ">"
Case Chr(13)
If session("admin_system") = "" Then
result = result + "<br>"
End If
Case Chr(34)
result = result + """
Case "&"
result = result + "&"
Case Chr(32)
‘'result = result + " "
If i + 1<= l And i -1>0 Then
If Mid(Str, i + 1, 1) = Chr(32) or Mid(Str, i + 1, 1) = Chr(9) or Mid(Str, i -1, 1) = Chr(32) or Mid(Str, i -1, 1) = Chr(9) Then
result = result + " "
Else
result = result + " "
End If
Else
result = result + " "
End If
Case Chr(9)
result = result + " "
Case Else
result = result + Mid(Str, i, 1)
End Select
Next
Htmlout = result
End Function
Rem - - - textarea顯示用 - - -
CODE Copy ...
Function htmlencode1(fString)
If fString<>"" And Not IsNull(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 = ""
End If
End Function
Rem - - - 頁(yè)面顯示用 - - -
CODE Copy ...
Function htmlencode2(fString)
If fString<>"" And Not IsNull(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 = ""
End If
End Function
Rem - - - 取出指定字符串前后的字符串方法 - - -
CODE Copy ...
Function GetStrs(str1, CharFlag, Dflag)
Dim tmpstr
If Dflag = 0 Then‘'取左
pos1 = InStr(str1, charFlag)
If pos1<= 20 Then
tmpstr = Left(str1, pos1 -1)
Else
tmpstr = Mid(str1, pos1 -20, 20)
End If
Else ‘'取右
pos1 = InStr(str1, charFlag) + Len(charFlag)
If Len(str1) - pos1<= 20 Then
tmpstr = Right(str1, Len(str1) - pos1)
Else
tmpstr = Mid(str1, pos1 + 1, 20)
End If
End If
GetStrs = tmpstr
End Function
Rem - - - 取出文件名 - - -
CODE Copy ...
Function GetFileName(Str)
pos = InStr(Str, ".")
If Str<>"" Then
Str = Mid(Str, pos, Len(Str))
End If
GetFileName = Str
End Function
Rem - - - 取到瀏覽器版本轉(zhuǎn)換字符串 - - -
CODE Copy ...
Function browser()
Dim text
text = Request.ServerVariables("HTTP_USER_AGENT")
If InStr(text, "MSIE 5.5")>0 Then
browser = "IE 5.5"
ElseIf InStr(text, "MSIE 6.0")>0 Then
browser = "IE 6.0"
ElseIf InStr(text, "MSIE 5.01")>0 Then
browser = "IE 5.01"
ElseIf InStr(text, "MSIE 5.0")>0 Then
browser = "IE 5.00"
ElseIf InStr(text, "MSIE 4.0")>0 Then
browser = "IE 4.01"
Else
browser = "未知"
End If
End Function
Rem - - - 取到系統(tǒng)腳本轉(zhuǎn)換字符串 - - -
CODE Copy ...
Function System(text)
If InStr(text, "NT 5.1")>0 Then
System = System + "Windows XP"
ElseIf InStr(text, "NT 5")>0 Then
System = System + "Windows 2000"
ElseIf InStr(text, "NT 4")>0 Then
System = System + "Windows NT4"
ElseIf InStr(text, "4.9")>0 Then
System = System + "Windows ME"
ElseIf InStr(text, "98")>0 Then
System = System + "Windows 98"
ElseIf InStr(text, "95")>0 Then
System = System + "Windows 95"
Else
System = System + "未知"
End If
End Function
Rem - - - = 刪除文件 - - -
CODE Copy ...
Function delfile(filepath)
imangepath = Trim(filepath)
Path = server.MapPath(imangepath)
Set fs = server.CreateObject("Scripting.FileSystemObject")
If FS.FileExists(Path) Then
FS.DeleteFile(Path)
End If
Set fs = Nothing
End Function
Rem - - - 得到真實(shí)的客戶端IP - - -
CODE Copy ...
Public Function GetClientIP()
Dim uIpAddr
‘' 本函數(shù)參考webcn.Net / AspHouse 文獻(xiàn)<取真實(shí)的客戶IP>
uIpAddr = Request.ServerVariables("HTTP_X_FORWARDED_FOR")
If uIpAddr = "" Then uIpAddr = Request.ServerVariables("REMOTE_ADDR")
GetClientIP = uIpAddr
uIpAddr = ""
End Function
%>
數(shù)據(jù)庫(kù)查詢中的特殊字符的問(wèn)題
在進(jìn)行數(shù)據(jù)庫(kù)的查詢時(shí)，會(huì)經(jīng)常遇到這樣的情況：
例如想在一個(gè)用戶數(shù)據(jù)庫(kù)中查詢他的用戶名和他的密碼，但恰好該用戶使用的名字和密碼中有特殊的字符，例如單引號(hào)，“|”號(hào)，雙引號(hào)或者連字符“&”。
例如他的名字是1"test，密碼是A|&900
這時(shí)當(dāng)你執(zhí)行以下的查詢語(yǔ)句時(shí)，肯定會(huì)報(bào)錯(cuò)：
SQL = "Select * FROM SecurityLevel Where UID="" & UserID & """
SQL = SQL & " AND PWD="" & Password & """
因?yàn)槟愕腟QL將會(huì)是這樣：
Select * FROM SecurityLevel Where UID="1"test" AND PWD="A|&900"
在SQL中，"|"為分割字段用的，顯然會(huì)出錯(cuò)了。現(xiàn)在提供下面的幾個(gè)函數(shù) 專門用來(lái)處理這些頭疼的東西：
Quoted from Unkown:
<%
Function ReplaceStr (TextIn, ByVal SearchStr As String, _
ByVal Replacement As String, _
ByVal CompMode As Integer)
Dim WorkText As String, Pointer As Integer
If IsNull(TextIn) Then
ReplaceStr = Null
Else
WorkText = TextIn
Pointer = InStr(1, WorkText, SearchStr, CompMode)
Do While Pointer > 0
WorkText = Left(WorkText, Pointer - 1) & Replacement & _
Mid(WorkText, Pointer + Len(SearchStr))
Pointer = InStr(Pointer + Len(Replacement), WorkText, SearchStr, CompMode)
Loop
ReplaceStr = WorkText
End If
End Function
Function SQLFixup(TextIn)
SQLFixup = ReplaceStr(TextIn, """, """", 0)
End Function
Function JetSQLFixup(TextIn)
Dim Temp
Temp = ReplaceStr(TextIn, """, """", 0)
JetSQLFixup = ReplaceStr(Temp, "|", "" & Chr(124) & "", 0)
End Function
Function FindFirstFixup(TextIn)
Dim Temp
Temp = ReplaceStr(TextIn, """, "" & chr(39) & "", 0)
FindFirstFixup = ReplaceStr(Temp, "|", "" & Chr(124) & "", 0)
End Function
Rem 借助RecordSet將二進(jìn)制流轉(zhuǎn)化成文本
Quoted from Unkown:
Function BinaryToString(biData, Size)
Const adLongVarChar = 201
Set RS = 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
End Function
%>
<%
'定義超全局變量
Dim URLSelf, URISelf
URISelf = Request.ServerVariables("SCRIPT_NAME")
If Request.QueryString = "" Then
URLSelf = URISelf
Else
URLSelf = URISelf & "?" & Request.QueryString
End If
Response.CharSet = "GB2312"
Response.Buffer = True
Response.Expires = -1
'===================================================================================
' 函數(shù)原型：GotoURL (URL)
'功能：轉(zhuǎn)到指定的URL
'參數(shù)：URL 要跳轉(zhuǎn)的URL
'返 回 值：無(wú)
'涉及的表：無(wú)
'===================================================================================
Public Function GotoURL(URL)
Response.Write "<script language=""JavaScript"">location.href='" & URL & "';</script>"
End Function
'===================================================================================
' 函數(shù)原型：MessageBox (Msg)
'功能：顯示消息框
'參數(shù)：要顯示的消息
'返 回 值：無(wú)
'涉及的表：無(wú)
'===================================================================================
Public Function MessageBox(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 "<script language=""JavaScript"">alert('" & msg & "');</script>"
End Function
'===================================================================================
' 函數(shù)原型：ReturnValue (bolValue)
'功能：設(shè)置Window對(duì)象的返回值：只能是布爾值
'參數(shù)：返回值
'返 回 值：無(wú)
'涉及的表：無(wú)
'===================================================================================
Public Function ReturnValue(bolValue)
If bolValue Then
Response.Write "<script language=""JavaScript"">window.returnValue=true;</script>"
Else
Response.Write "<script language=""JavaScript"">window.returnValue=false;</script>"
End If
End Function
'===================================================================================
' 函數(shù)原型：GoBack (URL)
'功能：后退
'參數(shù)：無(wú)
'返 回 值：無(wú)
'涉及的表：無(wú)
'===================================================================================
Public Function GoBack()
Response.Write "<script language=""JavaScript"">history.go(-1);</script>"
End Function
'===================================================================================
' 函數(shù)原型：CloseWindow ()
'功能：關(guān)閉窗口
'參數(shù)：無(wú)
'返 回 值：無(wú)
'涉及的表：無(wú)
'===================================================================================
Public Function CloseWindow()
Response.Write "<script language=""JavaScript"">window.opener=null;window.close();</script>"
End Function
'===================================================================================
' 函數(shù)原型：RefreshParent ()
'功能：刷新父框架
'參數(shù)：無(wú)
'返 回 值：無(wú)
'涉及的表：無(wú)
'===================================================================================
Public Function RefreshParent()
Response.Write "<script language=""JavaScript"">if(parent!=self) parent.location.reload();</script>"
End Function
'===================================================================================
' 函數(shù)原型：RefreshTop ()
'功能：刷新頂級(jí)框架
'參數(shù)：無(wú)
'返 回 值：無(wú)
'涉及的表：無(wú)
'===================================================================================
Public Function RefreshTop()
Response.Write "<script language=""JavaScript"">if(top!=self) top.location.reload();</script>"
End Function
'===================================================================================
' 函數(shù)原型：GenPassword (intLen,PassMask)
'功能：生成隨機(jī)密碼
'參數(shù)：intLen新密碼長(zhǎng)度
'PassMask生成密碼的掩碼默認(rèn)為空
'返 回 值：無(wú)
'涉及的表：無(wú)
'===================================================================================
Public Function GenPassword(intLen, PassMask)
Dim iCnt, PosTemp
Randomize
If PassMask = "" Then
PassMask = "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789abcdefghijklmnopqrstuvwxyz"
End If
For iCnt = 1 To intLen
PosTemp = Fix(Rnd(1) * (Len(PassMask))) + 1
GenPassword = GenPassword & Mid(PassMask, PosTemp, 1)
Next
End Function
'===================================================================================
' 函數(shù)原型：GenSerialString ()
'功能：生成序列號(hào)
'參數(shù)：無(wú)
'返 回 值：無(wú)
'涉及的表：無(wú)
'===================================================================================
Public Function GenSerialString()
GenSerialString = Year(Now())
If Month(Now())<10 Then
GenSerialString = GenSerialString & "0"
End If
GenSerialString = GenSerialString & Month(Now())
If Day(Now())<10 Then
GenSerialString = GenSerialString & "0"
End If
GenSerialString = GenSerialString & Day(Now())
If Hour(Now())<10 Then
GenSerialString = GenSerialString & "0"
End If
GenSerialString = GenSerialString & Hour(Now())
If Minute(Now())<10 Then
GenSerialString = GenSerialString & "0"
End If
GenSerialString = GenSerialString & Minute(Now())
If Second(Now())<10 Then
GenSerialString = GenSerialString & "0"
End If
GenSerialString = GenSerialString & Second(Now())
GenSerialString = GenSerialString & GenPassword(6, "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ")
End Function
'===================================================================================
' 函數(shù)原型：ChangePage(URLTemplete,PageIndex)
'功能：根據(jù)URL模板生成新的頁(yè)面URL
'參數(shù)：URLTempleteURL模板
' PageIndex新的頁(yè)碼
'返 回 值：生成的URL
'涉及的表：無(wú)
'===================================================================================
Public Function ChangePage(URLTemplete, PageIndex)
ChangePage = SetQueryString(URLTemplete, "PAGE", PageIndex)
End Function
'===================================================================================
' 函數(shù)原型：BuildPath(sPath)
'功能：根據(jù)指定的路徑創(chuàng)建目錄
'參數(shù)：sPathURL模板
'返 回 值：如果成功，返回空字符串，否則返回錯(cuò)誤信息和錯(cuò)誤位置
'涉及的表：無(wú)
'===================================================================================
Public Function BuildPath (sPath)
Dim iCnt
Dim Path
Dim BasePath
Path = Split(sPath, "/")
If Left(sPath, 1) = "/" or Left(sPath, 1) = "\" Then
BasePath = Server.MapPath("/")
Else
BasePath = Server.MapPath(".")
End If
Dim cPath, oFso
cPath = BasePath
BuildPath = ""
Set oFso = Server.CreateObject("Scripting.FileSystemObject")
For iCnt = LBound(Path) To UBound(Path)
If Trim(Path(iCnt))<>"" Then
cPath = cPath & "\" & Trim(Path(iCnt))
If Not oFso.FolderExists(cPath) Then
On Error Resume Next
oFso.CreateFolder cPath
If Err.Number<>0 Then
BuildPath = Err.Description & "[" & cPath & "]"
Exit For
End If
On Error GoTo 0
End If
End If
Next
Set oFso = Nothing
End Function
'===================================================================================
' 函數(shù)原型：GetUserAgentInfo(ByRef vSoft,ByRef vOs)
'功能：獲取客戶端操作系統(tǒng)和瀏覽器信息
'參數(shù)：vSoft瀏覽器信息
'vOs操作系統(tǒng)信息
'返 回 值：無(wú)
'涉及的表：無(wú)
'===================================================================================
Public Function GetUserAgentInfo(ByRef vSoft, ByRef vOs)
Dim theSoft
theSoft = Request.ServerVariables("HTTP_USER_AGENT")
' 瀏覽器
If InStr(theSoft, "NetCaptor") Then
vSoft = "NetCaptor"
ElseIf InStr(theSoft, "MSIE 6") Then
vSoft = "MSIE 6.0"
ElseIf InStr(theSoft, "MSIE 5.5+") Then
vSoft = "MSIE 5.5"
ElseIf InStr(theSoft, "MSIE 5") Then
vSoft = "MSIE 5.0"
ElseIf InStr(theSoft, "MSIE 4") Then
vSoft = "MSIE 4.0"
ElseIf InStr(theSoft, "Netscape") Then
vSoft = "Netscape"
ElseIf InStr(theSoft, "Opera") Then
vSoft = "Opera"
Else
vSoft = "Other"
End If
' 操作系統(tǒng)
If InStr(theSoft, "Windows NT 5.0") Then
vOs = "Windows 2000"
ElseIf InStr(theSoft, "Windows NT 5.1") Then
vOs = "Windows XP"
ElseIf InStr(theSoft, "Windows NT 5.2") Then
vOs = "Windows 2003"
ElseIf InStr(theSoft, "Windows NT") Then
vOs = "Windows NT"
ElseIf InStr(theSoft, "Windows 9") Then
vOs = "Windows 9x"
ElseIf InStr(theSoft, "unix") Then
vOs = "Unix"
ElseIf InStr(theSoft, "linux") Then
vOs = "Linux"
ElseIf InStr(theSoft, "SunOS") Then
vOs = "SunOS"
ElseIf InStr(theSoft, "BSD") Then
vOs = "BSD"
ElseIf InStr(theSoft, "Mac") Then
vOs = "Mac"
Else
vOs = "Other"
End If
End Function
'===================================================================================
' 函數(shù)原型：GetRegexpObject()
'功能：獲得一個(gè)正則表達(dá)式對(duì)象
'參數(shù)：無(wú)
'返 回 值：正則表達(dá)式對(duì)象
'涉及的表：無(wú)
'===================================================================================
Public Function GetRegExpObject(sPattern)
Dim r
Set r = New RegExp
r.Global = True
r.IgnoreCase = True
r.MultiLine = True
r.Pattern = sPattern
Set GetRegexpObject = r
Set r = Nothing
End Function
'===================================================================================
' 函數(shù)原型：RegExpTest(pattern,string)
'功能：正則表達(dá)式檢測(cè)
'參數(shù)：pattern模式字符串
'string待檢查的字符串
'返 回 值：是否匹配
'涉及的表：無(wú)
'===================================================================================
Public Function RegExpTest(p, s)
Dim r
Set r = GetRegExpObject(p)
RegExpTest = r.Test(s)
Set r = Nothing
End Function
'===================================================================================
' 函數(shù)原型：RegExpReplace(sSource,sPattern,sRep)
'功能：正則表達(dá)式替換
'參數(shù)：sSource要替換的源字符串
'sPattern模式字符串
'sRep要替換的目標(biāo)字符串
'返 回 值：替換后的字符串
'涉及的表：無(wú)
'===================================================================================
Public Function RegExpReplace(sSource, sPattern, sRep)
Dim r
Set r = GetRegExpTest(sPattern)
RegExpReplace = r.Replace(sSource, sRep)
Set r = Nothing
End Function
'===================================================================================
' 函數(shù)原型：CreateXMLParser()
'功能：創(chuàng)建一個(gè)盡可能高版本的XMLDOM
'參數(shù)：無(wú)
'返 回 值：IDOMDocument對(duì)象
'涉及的表：無(wú)
'===================================================================================
Public Function CreateXMLParser()
On Error Resume Next
Set CreateXMLParser = Server.CreateObject("MSXML2.DOMDocument.4.0")
If Err.Number<>0 Then
Err.Clear
Set CreateXMLParser = Server.CreateObject("MSXML2.DOMDocument.3.0")
If Err.Number<>0 Then
Err.Clear
Set CreateXMLParser = Server.CreateObject("MSXML2.DOMDocument.2.6")
If Err.Number<>0 Then
Err.Clear
Set CreateXMLParser = Server.CreateObject("MSXML2.DOMDocument")
If Err.Number<>0 Then
Err.Clear
Set CreateXMLParser = Server.CreateObject("Microsoft.XMLDOM")
If Err.Number<>0 Then
Err.Clear
Set CreateXMLParser = Nothing
Else
Exit Function
End If
Else
Exit Function
End If
Else
Exit Function
End If
Else
Exit Function
End If
Else
Exit Function
End If
On Error GoTo 0
End Function
'===================================================================================
' 函數(shù)原型：CreateHTTPPoster()
'功能：創(chuàng)建一個(gè)盡可能高版本的XMLHTTP
'參數(shù)：ServerOrClient創(chuàng)建ServerXMLHTTP還是XMLHTTP
'返 回 值：IXMLHTTP對(duì)象
'涉及的表：無(wú)
'===================================================================================
Public Function CreateHTTPPoster(soc)
Dim s
If soc Then
s = "ServerXMLHTTP"
Else
s = "XMLHTTP"
End If
On Error Resume Next
Set CreateHTTPPoster = Server.CreateObject("MSXML2." & s & ".4.0")
If Err.Number<>0 Then
Err.Clear
Set CreateHTTPPoster = Server.CreateObject("MSXML2." & s & ".3.0")
If Err.Number<>0 Then
Err.Clear
Set CreateHTTPPoster = Server.CreateObject("MSXML2." & s)
If Err.Number<>0 Then
Set CreateHTTPPoster = Nothing
Else
Exit Function
End If
Else
Exit Function
End If
Else
Exit Function
End If
On Error GoTo 0
End Function
'===================================================================================
' 函數(shù)原型：XMLThrowError (errCode,errReason)
'功能：拋出一個(gè)XML錯(cuò)誤消息
'參數(shù)：errCode錯(cuò)誤編碼
'errReason錯(cuò)誤原因
'返 回 值：無(wú)
'涉及的表：無(wú)
'===================================================================================
Public Sub XMLThrowError (errCode, errReason)
Response.Clear
Response.ContentType = "text/xml"
Response.Write"<?xml version=""1.0"" encoding=""gb2312"" standalone=""yes"" ?>" & vbCrLf & _
"<ERROR CODE=""" & errCode & """ REASON=""" & errReason & """ />" & vbCrLf
Response.Flush
Response.End
End Sub
'===================================================================================
' 函數(shù)原型：GetXMLNodeValue(ByRef xmlDom,sFilter,sDefValue)
'功能：從一個(gè)XML文檔中查找指定節(jié)點(diǎn)的值
'參數(shù)：xmlDomXML文檔
'sFilterXPATH定位字符串
'sDefValue默認(rèn)值
'返 回 值：無(wú)
'涉及的表：無(wú)
'===================================================================================
Public Function GetXMLNodeValue(ByRef xmlDom, sFilter, sDefValue)
Dim oNode
Set oNode = xmlDom.selectSingleNode(sFilter)
If TypeName(oNode) = "Nothing" or TypeName(oNode) = "Null" or TypeName(oNode) = "Empty" Then
GetXMLNodeValue = sDefValue
Set oNode = Nothing
Else
GetXMLNodeValue = Trim(oNode.Text)
Set oNode = Nothing
End If
End Function
'===================================================================================
' 函數(shù)原型：GetXMLNodeAttribute(ByRef xmlDom,sFilter,sName,sDefValue)
'功能：從一個(gè)XML文檔中查找指定節(jié)點(diǎn)的指定屬性
'參數(shù)：xmlDomXML文檔
'sFilterXPATH定位字符串
'sName要查詢的屬性名稱
'sDefValue默認(rèn)值
'返 回 值：無(wú)
'涉及的表：無(wú)
'===================================================================================
Public Function GetXMLNodeAttribute(ByRef xmlDom, sFilter, sName, sDefValue)
Dim oNode
Set oNode = xmlDom.selectSingleNode(sFilter)
If TypeName(oNode) = "Nothing" or TypeName(oNode) = "Null" or TypeName(oNode) = "Empty" Then
GetXMLNodeAttribute = sDefValue
Set oNode = Nothing
Else
Dim pTemp
Set pTemp = oNode.getAttribute(sName)
If TypeName(pTemp) = "Nothing" or TypeName(pTemp) = "Null" or TypeName(pTemp) = "Empty" Then
GetXMLNodeAttribute = sDefValue
Set oNode = Nothing
Set pTemp = Nothing
Else
GetXMLNodeAttribute = Trim(pTemp.Value)
Set oNode = Nothing
Set pTemp = Nothing
End If
End If
End Function
'===================================================================================
' 函數(shù)原型：GetQueryStringNumber (FieldName,defValue)
'功能：從QueryString獲取一個(gè)整數(shù)
'參數(shù)：FieldName參數(shù)名
'defValue默認(rèn)值
'返 回 值：無(wú)
'涉及的表：無(wú)
'===================================================================================
Public Function GetQueryStringNumber (FieldName, defValue)
Dim r
r = Request.QueryString(FieldName)
If r = "" Then
GetQueryStringNumber = defValue
Exit Function
Else
If Not IsNumeric(r) Then
GetQueryStringNumber = defValue
Exit Function
Else
On Error Resume Next
r = CDbl(r)
If Err.Number<>0 Then
Err.Clear
GetQueryStringNumber = defValue
Exit Function
Else
GetQueryStringNumber = r
End If
On Error GoTo 0
End If
End If
End Function
'===================================================================================
' 函數(shù)原型：I(yíng)If (testExpr,value1,value2)
'功能：相當(dāng)于C/C++里面的 ?: 運(yùn)算符
'參數(shù)：testExprBoolean表達(dá)式
'value1testExpr=True 時(shí)的取值
'value2testExpr=False 時(shí)的取值
'返 回 值：如果testExpr為True返回value1否則返回value2
'涉及的表：無(wú)
'說(shuō)明：VBScript里沒有Iif函數(shù)
'===================================================================================
Public Function IIf(testExpr, value1, value2)
If testExpr = True Then
IIf = value1
Else
IIf = value2
End If
End Function
'===================================================================================
' 函數(shù)原型：URLEncoding (v,f)
'功能：URL編碼函數(shù)
'參數(shù)：v中英文混合字符串
'f是否對(duì)ASCII字符編碼
'返 回 值：編碼后的ASC字符串
'涉及的表：無(wú)
'===================================================================================
Public Function URLEncoding(v, f)
Dim s, t, i, j, h, l, x
s = ""
x = Len(v)
For i = 1 To x
t = Mid(v, i, 1)
j = Asc(t)
If j> 0 Then
If f Then
s = s & "%" & Right("00" & Hex(Asc(t)), 2)
Else
s = s & t
End If
Else
If j < 0 Then j = j + &H10000
h = (j And &HFF00) \ &HFF
l = j And &HFF
s = s & "%" & Hex(h) & "%" & Hex(l)
End If
Next
URLEncoding = s
End Function
'===================================================================================
' 函數(shù)原型：URLDecoding (sIn)
'功能：URL解碼碼函數(shù)
'參數(shù)：vURL編碼的字符串
'返 回 值：解碼后的字符串
'涉及的表：無(wú)
'===================================================================================
Public Function URLDecoding(Sin)
Dim s, i, l, c, t, n
s = ""
l = Len(Sin)
For i = 1 To l
c = Mid(Sin, i, 1)
If c<>"%" Then
s = s & c
Else
c = Mid(Sin, i + 1, 2)
i = i + 2
t = CInt("&H" & c)
If t<&H80 Then
s = s & Chr(t)
Else
c = Mid(Sin, i + 1, 3)
If Left(c, 1)<>"%" Then
URLDecoding = s
Exit Function
Else
c = Right(c, 2)
n = CInt("&H" & c)
t = t * 256 + n -65536
s = s & Chr(t)
i = i + 3
End If
End If
End If
Next
URLDecoding = s
End Function
'===================================================================================
' 函數(shù)原型：Bytes2BSTR (v)
'功能：UTF-8編碼轉(zhuǎn)換到正常的GB2312
'參數(shù)：vUTF-8編碼字節(jié)流
'返 回 值：解碼后的字符串
'涉及的表：無(wú)
'===================================================================================
Public Function Bytes2BSTR(v)
Dim r, i, t, n
r = ""
For i = 1 To LenB(v)
t = AscB(MidB(v, i, 1))
If t < &H80 Then
r = r & Chr(t)
Else
n = AscB(MidB(v, i + 1, 1))
r = r & Chr(CLng(t) * &H100 + CInt(n))
i = i + 1
End If
Next
Bytes2BSTR = r
End Function
%>
相關(guān)文章
javascript asp教程服務(wù)器對(duì)象
javascript asp教程服務(wù)器對(duì)象...2007-03-03
Asp DatePart 函數(shù)的語(yǔ)法詳解(用于計(jì)算日期并返回指定的時(shí)間間隔)
ASP(VBScript) 參考手冊(cè)中，已經(jīng)對(duì) DatePart 作了說(shuō)明，但其對(duì)第一個(gè)參數(shù)的解釋太過(guò)書面，造成令人誤解，現(xiàn)重新解釋一下2012-07-07
asp下清空對(duì)象的分析2008-08-08
用ASP實(shí)現(xiàn)距指定日期的倒記時(shí)程序源碼
用ASP實(shí)現(xiàn)距指定日期的倒記時(shí)程序源碼...2007-03-03
使用類，實(shí)現(xiàn)模塊化...2006-06-06
送給搞采集的兄弟一個(gè)sql語(yǔ)句...2006-06-06
ASP編程入門進(jìn)階（十六）：FSO組件之驅(qū)動(dòng)器操作
ASP編程入門進(jìn)階（十六）：FSO組件之驅(qū)動(dòng)器操作...2007-01-01
許多人在編寫程序的時(shí)候因?yàn)樨潏D方便或不小心使用到程式的保留字，有時(shí)明明程序沒有錯(cuò)，就是無(wú)法正確執(zhí)行。您知道有哪些常見的保留字嗎2012-10-10
ASP文章系統(tǒng)解決方案實(shí)現(xiàn)上一頁(yè)下一頁(yè)
ASP文章系統(tǒng)解決方案實(shí)現(xiàn)上一頁(yè)下一頁(yè)...2007-01-01
這篇文章主要為大家分享幾個(gè)超精華的asp代碼，學(xué)習(xí)asp的朋友可以參考一下2006-12-12