Function Userip() Dim GetClientIP '如果客户端用了代理服务器，则应该用ServerVariables("HTTP_X_FORWARDED_FOR")方法 GetClientIP = Request.ServerVariables("HTTP_X_FORWARDED_FOR") If GetClientIP = "" or IsNull(GetClientIP) or IsEmpty(GetClientIP) Then '如果客户端没用代理，应该用Request.ServerVariables("REMOTE_ADDR")方法 GetClientIP = Request.ServerVariables("REMOTE_ADDR") End If Userip = GetClientIP End Function
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
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
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
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
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
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
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
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
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
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
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
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
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
If lEncodedLength Mod 32 > 0 Then lEncodedLength = lEncodedLength + 32 - (lEncodedLength Mod 32) End If ReDim bytIn(lEncodedLength - 1) ReDim bytOut(lEncodedLength - 1)
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
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
' 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"
'****************************************************************** '执行sql语句，不返回值,sql语句最好是如下： '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
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
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) 返回指定数目的从字符串的左边算起的字符，区分单双字节。
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) '生成随机字符，n为字符的个数 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) '生成随机数字，n为数字的个数 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
Function Userip() Dim GetClientIP '如果客户端用了代理服务器，则应该用ServerVariables("HTTP_X_FORWARDED_FOR")方法 GetClientIP = Request.ServerVariables("HTTP_X_FORWARDED_FOR") If GetClientIP = "" or IsNull(GetClientIP) or IsEmpty(GetClientIP) Then '如果客户端没用代理，应该用Request.ServerVariables("REMOTE_ADDR")方法 GetClientIP = Request.ServerVariables("REMOTE_ADDR") End If Userip = GetClientIP End Function
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
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
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
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
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
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) '生成随机字符，n为字符的个数 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) '生成随机数字，n为数字的个数 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
Function Userip() Dim GetClientIP '如果客户端用了代理服务器，则应该用ServerVariables("HTTP_X_FORWARDED_FOR")方法 GetClientIP = Request.ServerVariables("HTTP_X_FORWARDED_FOR") If GetClientIP = "" or IsNull(GetClientIP) or IsEmpty(GetClientIP) Then '如果客户端没用代理，应该用Request.ServerVariables("REMOTE_ADDR")方法 GetClientIP = Request.ServerVariables("REMOTE_ADDR") End If Userip = GetClientIP End Function
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
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
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
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
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数据库连接: % Option Explicit Dim startime, endtime, conn, connstr, db startime = Timer() '更改数据库名字 db = "data/dvBBS5.mdb" Set conn = Server.CreateObject("ADODB.Connection") connstr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" Server.MapPath(db) '如果你的服务器采用较老版本Access驱动，请用下面连接方法 'connstr="driver={Microsoft Access Driver (*.mdb)};dbq=" Server.MapPath(db) conn.Open connstr
Function CloseDatabase Conn.Close Set conn = Nothing End Function %> 12.SQL数据库连接: % 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.用键盘打开网页代码: script language="javascript"> function ctlent(eventobject) { if((event.ctrlKey window.event.keyCode==13)||(event.altKey window.event.keyCode==83)) { window.open('网址','','') } } /script> 这里是Ctrl+Enter和Alt+S的代码 自己查下键盘的ASCII码再换就行 14.让层不被控件复盖代码: 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.动网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"你还没有注册或登陆论坛","0","精品论坛" location.href = "login.asp" /script> 16.使用FSO修改文件特定内容的函数 % 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读取文件内容的函数 % 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读取文件某一行的函数 % 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写文件某一行的函数 % 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添加文件新行的函数 % 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.读文件最后一行的函数 % 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.点击返回上页代码: form> p>input TYPE="button" value="返回上一步" onCLICK="history.back(-1)">/p> /form> 24.点击刷新代码: form> p>input TYPE="button" value="刷新按钮一" onCLICK="ReloadButton()">/p> /form> script language="javascript">!-- function ReloadButton(){location.href="allbutton.htm";} // -->/script> 24.点击刷新代码2: form> p>input TYPE="button" value="刷新按钮二" onClick="history.go(0)"> /p> /form> form> p>input TYPE="button" value="打开一个网站" onCLICK="HomeButton()">/p> /form> script language="javascript">!-- function HomeButton(){location.href="http://nettrain.126.com";;;} // -->/script> 25.弹出警告框代码: form> p>input TYPE="button" value="弹出警告框" onCLICK="AlertButton()">/p> /form> script language="javascript">!-- function AlertButton(){window.alert("要多多光临呀！");} // -->/script> 26.状态栏信息 form> p>input TYPE="button" value="状态栏信息" 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.点击打开新窗口 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.分页代码: %''本程序文件名为：Pages.asp%> %''包含ADO常量表文件adovbs.inc，可从"\Program Files\Common Files\System\ADO"目录下拷贝%> !--#Include File="adovbs.inc"--> %''＊建立数据库连接，这里是Oracle8.05数据库 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") ''创建Recordset对象 rs.CursorLocation = adUseClient ''设定记录集指针属性 ''＊设定一页内的记录总数，可根据需要进行调整 rs.PageSize = 10 ''＊设置查询语句 StrSQL = "Select ID,姓名,住址,电话 from 通讯录 order By ID" rs.Open StrSQL, conn, adOpenStatic, adLockReadOnly, adCmdText %> HTML> HEAD> title>分页示例/title> script language=javascript> //点击"[第一页]"时响应： function PageFirst() { document.MyForm.CurrentPage.selectedIndex=0; document.MyForm.CurrentPage.onchange(); } //点击"[上一页]"时响应： function PagePrior() { document.MyForm.CurrentPage.selectedIndex--; document.MyForm.CurrentPage.onchange(); } //点击"[下一页]"时响应： function PageNext() { document.MyForm.CurrentPage.selectedIndex++; document.MyForm.CurrentPage.onchange(); } //点击"[最后一页]"时响应： function PageLast() { document.MyForm.CurrentPage.selectedIndex=document.MyForm.CurrentPage.length-1; document.MyForm.CurrentPage.onchange(); } //选择"第？页"时响应： 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>[数据库中没有记录！]/font>") Else ''指定当前页码 If Request("CurrentPage") = "" Then rs.AbsolutePage = 1 Else rs.AbsolutePage = CLng(Request("CurrentPage")) End If ''创建表单MyForm,方法为Get Response.Write("form method=Get name=MyForm>") Response.Write("p align=center>font size=2 color=#008000>") ''设置翻页超链接 If rs.PageCount = 1 Then Response.Write("[第一页] [上一页] [下一页] [最后一页] ") Else If rs.AbsolutePage = 1 Then Response.Write("[第一页] [上一页] ") Response.Write("[a href=java script:PageNext()>下一页/a>] ") Response.Write("[a href=java script:PageLast()>最后一页/a>] ") Else If rs.AbsolutePage = rs.PageCount Then Response.Write("[a href=java script:PageFirst()>第一页/a>] ") Response.Write("[a href=java script:PagePrior()>上一页/a>] ") Response.Write("[下一页] [最后一页] ") Else Response.Write("[a href=java script:PageFirst()>第一页/a>] ") Response.Write("[a href=java script:PagePrior()>上一页/a>] ") Response.Write("[a href=java script:PageNext()>下一页/a>] ") Response.Write("[a href=java script:PageLast()>最后一页/a>] ") End If End If End If ''创建下拉列表框，用于选择浏览页码 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>") ''当前页码 Else Response.Write("option>"i"/option>") End If Next Response.Write("/select>页/共"rs.PageCount"页 共"rs.RecordCount"条记录/font>p>") Response.Write("/form>") ''创建表格，用于显示 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>") ''显示内容 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 - - - 表单提示函数 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
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
Function get_rand() Dim num1 Dim rndnum Randomize Do While Len(rndnum)4 num1 = CStr(Chr((57 -48) * Rnd + 48)) rndnum = rndnumnum1 Loop get_rand = rndnum End Function
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
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
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过滤函数 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 + "lt;" Case ">" result = result + "gt;" Case Chr(13) If session("admin_system") = "" Then result = result + "br>" End If Case Chr(34) result = result + "quot;" Case "" result = result + "" Case Chr(32) ‘'result = result + "nbsp;" 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 + "nbsp;" Else result = result + " " End If Else result = result + "nbsp;" 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, "gt;", ">") fString = Replace(fString, "lt;", "") fString = Replace(fString, "nbsp;", 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 - - - 页面显示用 - - - CODE Copy ...
Function htmlencode2(fString) If fString>"" And Not IsNull(fString) Then fString = Replace(fString, ">", "gt;") fString = Replace(fString, "", "lt;") fString = Replace(fString, Chr(32), "nbsp;") 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 - - - 取到浏览器版本转换字符串 - - - 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 - - - 取到系统脚本转换字符串 - - - 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 - - - 得到真实的客户端IP - - - CODE Copy ...
Public Function GetClientIP() Dim uIpAddr ‘' 本函数参考webcn.Net / AspHouse 文献取真实的客户IP> uIpAddr = Request.ServerVariables("HTTP_X_FORWARDED_FOR") If uIpAddr = "" Then uIpAddr = Request.ServerVariables("REMOTE_ADDR") GetClientIP = uIpAddr uIpAddr = "" End Function
%>
数据库查询中的特殊字符的问题 在进行数据库的查询时，会经常遇到这样的情况： 例如想在一个用户数据库中查询他的用户名和他的密码，但恰好该用户使用的名字和密码中有特殊的字符，例如单引号，“|”号，双引号或者连字符“”。 例如他的名字是1"test，密码是A|900 这时当你执行以下的查询语句时，肯定会报错： SQL = "Select * FROM SecurityLevel Where UID="" UserID """ SQL = SQL " AND PWD="" Password """ 因为你的SQL将会是这样： Select * FROM SecurityLevel Where UID="1"test" AND PWD="A|900" 在SQL中，"|"为分割字段用的，显然会出错了。现在提供下面的几个函数 专门用来处理这些头疼的东西： 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将二进制流转化成文本 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
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
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
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
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
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 ' 操作系统 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
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
Public Function RegExpReplace(sSource, sPattern, sRep) Dim r Set r = GetRegExpTest(sPattern) RegExpReplace = r.Replace(sSource, sRep) Set r = Nothing End Function
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
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
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
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
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
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
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 tH80 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
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 %>
咨 询 客 服