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"
'****************************************************************** '執(zhí)行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) 返回指定數(shù)目的從字符串的左邊算起的字符，區(qū)分單雙字節(jié)。
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為字符的個數(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) '生成隨機數(shù)字，n為數(shù)字的個數(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
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為字符的個數(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) '生成隨機數(shù)字，n為數(shù)字的個數(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
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數(shù)據(jù)庫連接: % Option Explicit Dim startime, endtime, conn, connstr, db startime = Timer() '更改數(shù)據(jù)庫名字 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數(shù)據(jù)庫連接: % 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修改文件特定內容的函數(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讀取文件內容的函數(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.點擊返回上頁代碼: 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.;;;} // -->/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.點擊打開新窗口 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"--> %''＊建立數(shù)據(jù)庫連接，這里是Oracle8.05數(shù)據(jù)庫 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對象 rs.CursorLocation = adUseClient ''設定記錄集指針屬性 ''＊設定一頁內的記錄總數(shù)，可根據(jù)需要進行調整 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>[數(shù)據(jù)庫中沒有記錄！]/font>") Else ''指定當前頁碼 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>") ''設置翻頁超鏈接 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 ''創(chuàng)建下拉列表框，用于選擇瀏覽頁碼 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>") ''創(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>") ''顯示內容 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
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過濾函數(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 + "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 - - - 取到系統(tǒng)腳本轉換字符串 - - - 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 ‘' 本函數(shù)參考webcn.Net / AspHouse 文獻取真實的客戶IP> uIpAddr = Request.ServerVariables("HTTP_X_FORWARDED_FOR") If uIpAddr = "" Then uIpAddr = Request.ServerVariables("REMOTE_ADDR") GetClientIP = uIpAddr uIpAddr = "" End Function
%>
數(shù)據(jù)庫查詢中的特殊字符的問題 在進行數(shù)據(jù)庫的查詢時，會經常遇到這樣的情況： 例如想在一個用戶數(shù)據(jù)庫中查詢他的用戶名和他的密碼，但恰好該用戶使用的名字和密碼中有特殊的字符，例如單引號，“|”號，雙引號或者連字符“”。 例如他的名字是1"test，密碼是A|900 這時當你執(zhí)行以下的查詢語句時，肯定會報錯： 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中，"|"為分割字段用的，顯然會出錯了?，F(xiàn)在提供下面的幾個函數(shù) 專門用來處理這些頭疼的東西： 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 ' 操作系統(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
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 %>
