動網中用到的幾個Function和一個JS[base64encode,base64decode,md5,sendmail,js]

<%

dim sBASE_64_CHARACTERS

dim len1,k

dim asc1,asContents1

dim varchar,varasc,varHex,varlow,varhigh

sBASE_64_CHARACTERS = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"

sBASE_64_CHARACTERS = strUnicode2Ansi(sBASE_64_CHARACTERS)

Function strUnicodeLen(asContents)

'計算unicode字符串的Ansi編碼的長度

asContents1="a"&asContents

len1=len(asContents1)

k=0

for i=1 to len1

asc1=asc(mid(asContents1,i,1))

if asc1<0 then asc1=65536+asc1

if asc1>255 then

k=k+2

else

k=k+1

end if

next

strUnicodeLen=k-1

End Function

Function strUnicode2Ansi(asContents)

'將Unicode編碼的字符串，轉換成Ansi編碼的字符串

strUnicode2Ansi=""

len1=len(asContents)

for i=1 to len1

varchar=mid(asContents,i,1)

varasc=asc(varchar)

if varasc<0 then varasc=varasc+65536

if varasc>255 then

varHex=Hex(varasc)

varlow=left(varHex,2)

varhigh=right(varHex,2)

strUnicode2Ansi=strUnicode2Ansi & chrb("&H" & varlow ) & chrb("&H" & varhigh )

else

strUnicode2Ansi=strUnicode2Ansi & chrb(varasc)

end if

next

End function

Function strAnsi2Unicode(asContents)

'將Ansi編碼的字符串，轉換成Unicode編碼的字符串

strAnsi2Unicode = ""

if isnull(asContents) or asContents="" then exit function

len1=lenb(asContents)

if len1=0 then exit function

for i=1 to len1

varchar=midb(asContents,i,1)

varasc=ascb(varchar)

if varasc > 127 then

if midb(asContents,i+1,1)<>"" then

strAnsi2Unicode = strAnsi2Unicode & chr(ascw(midb(asContents,i+1,1) & varchar))

end if

i=i+1

else

strAnsi2Unicode = strAnsi2Unicode & chr(varasc)

end if

next

End function

Function Base64encode(asContents)

'將Ansi編碼的字符串進行Base64編碼

'asContents應當是ANSI編碼的字符串（二進制的字符串也可以）

Dim lnPosition

Dim lsResult

Dim Char1

Dim Char2

Dim Char3

Dim Char4

Dim Byte1

Dim Byte2

Dim Byte3

Dim SaveBits1

Dim SaveBits2

Dim lsGroupBinary

Dim lsGroup64

Dim m3,m4,len1,len2

len1=Lenb(asContents)

if len1<1 then

Base64encode=""

exit Function

end if

m3=Len1 Mod 3

If M3 > 0 Then asContents = asContents & String(3-M3, chrb(0))

'補足位數是為了便於計算

IF m3 > 0 THEN

len1=len1+(3-m3)

len2=len1-3

else

len2=len1

end if

lsResult = ""

For lnPosition = 1 To len2 Step 3

lsGroup64 = ""

lsGroupBinary = Midb(asContents, lnPosition, 3)

Byte1 = Ascb(Midb(lsGroupBinary, 1, 1)): SaveBits1 = Byte1 And 3

Byte2 = Ascb(Midb(lsGroupBinary, 2, 1)): SaveBits2 = Byte2 And 15

Byte3 = Ascb(Midb(lsGroupBinary, 3, 1))

Char1 = Midb(sBASE_64_CHARACTERS, ((Byte1 And 252) \ 4) + 1, 1)

Char2 = Midb(sBASE_64_CHARACTERS, (((Byte2 And 240) \ 16) Or (SaveBits1 * 16) And &HFF) + 1, 1)

Char3 = Midb(sBASE_64_CHARACTERS, (((Byte3 And 192) \ 64) Or (SaveBits2 * 4) And &HFF) + 1, 1)

Char4 = Midb(sBASE_64_CHARACTERS, (Byte3 And 63) + 1, 1)

lsGroup64 = Char1 & Char2 & Char3 & Char4

lsResult = lsResult & lsGroup64

Next

'處理最後剩餘的幾個字符

if M3 > 0 then

lsGroup64 = ""

lsGroupBinary = Midb(asContents, len2+1, 3)

Byte1 = Ascb(Midb(lsGroupBinary, 1, 1)): SaveBits1 = Byte1 And 3

Byte2 = Ascb(Midb(lsGroupBinary, 2, 1)): SaveBits2 = Byte2 And 15

Byte3 = Ascb(Midb(lsGroupBinary, 3, 1))

Char1 = Midb(sBASE_64_CHARACTERS, ((Byte1 And 252) \ 4) + 1, 1)

Char2 = Midb(sBASE_64_CHARACTERS, (((Byte2 And 240) \ 16) Or (SaveBits1 * 16) And &HFF) + 1, 1)

Char3 = Midb(sBASE_64_CHARACTERS, (((Byte3 And 192) \ 64) Or (SaveBits2 * 4) And &HFF) + 1, 1)

if M3=1 then

lsGroup64 = Char1 & Char2 & ChrB(61) & ChrB(61) '用=號補足位數

else

lsGroup64 = Char1 & Char2 & Char3 & ChrB(61) '用=號補足位數

end if

lsResult = lsResult & lsGroup64

end if

Base64encode = lsResult

End Function

Function Base64decode(asContents)

'將Base64編碼字符串轉換成Ansi編碼的字符串

'asContents應當也是ANSI編碼的字符串（二進制的字符串也可以）

Dim lsResult

Dim lnPosition

Dim lsGroup64, lsGroupBinary

Dim Char1, Char2, Char3, Char4

Dim Byte1, Byte2, Byte3

Dim M4,len1,len2

len1= Lenb(asContents)

M4 = len1 Mod 4

if len1 < 1 or M4 > 0 then

'字符串長度應當是4的倍數

Base64decode = ""

exit Function

end if

'判斷最後一位是不是 = 號

'判斷倒數第二位是不是 = 號

'這裡m4表示最後剩餘的需要單獨處理的字符個數

if midb(asContents, len1, 1) = chrb(61) then m4=3

if midb(asContents, len1-1, 1) = chrb(61) then m4=2

if m4 = 0 then

len2=len1

else

len2=len1-4

end if

For lnPosition = 1 To Len2 Step 4

lsGroupBinary = ""

lsGroup64 = Midb(asContents, lnPosition, 4)

Char1 = InStrb(sBASE_64_CHARACTERS, Midb(lsGroup64, 1, 1)) - 1

Char2 = InStrb(sBASE_64_CHARACTERS, Midb(lsGroup64, 2, 1)) - 1

Char3 = InStrb(sBASE_64_CHARACTERS, Midb(lsGroup64, 3, 1)) - 1

Char4 = InStrb(sBASE_64_CHARACTERS, Midb(lsGroup64, 4, 1)) - 1

Byte1 = Chrb(((Char2 And 48) \ 16) Or (Char1 * 4) And &HFF)

Byte2 = lsGroupBinary & Chrb(((Char3 And 60) \ 4) Or (Char2 * 16) And &HFF)

Byte3 = Chrb((((Char3 And 3) * 64) And &HFF) Or (Char4 And 63))

lsGroupBinary = Byte1 & Byte2 & Byte3

lsResult = lsResult & lsGroupBinary

Next

'處理最後剩餘的幾個字符

if M4 > 0 then

lsGroupBinary = ""

lsGroup64 = Midb(asContents, len2+1, m4) & chrB(65) 'chr(65)=A，轉換成值為0

if M4=2 then '補足4位，是為了便於計算

lsGroup64 = lsGroup64 & chrB(65)

end if

Char1 = InStrb(sBASE_64_CHARACTERS, Midb(lsGroup64, 1, 1)) - 1

Char2 = InStrb(sBASE_64_CHARACTERS, Midb(lsGroup64, 2, 1)) - 1

Char3 = InStrb(sBASE_64_CHARACTERS, Midb(lsGroup64, 3, 1)) - 1

Char4 = InStrb(sBASE_64_CHARACTERS, Midb(lsGroup64, 4, 1)) - 1

Byte1 = Chrb(((Char2 And 48) \ 16) Or (Char1 * 4) And &HFF)

Byte2 = lsGroupBinary & Chrb(((Char3 And 60) \ 4) Or (Char2 * 16) And &HFF)

Byte3 = Chrb((((Char3 And 3) * 64) And &HFF) Or (Char4 And 63))

if M4=2 then

lsGroupBinary = Byte1

elseif M4=3 then

lsGroupBinary = Byte1 & Byte2

end if

lsResult = lsResult & lsGroupBinary

end if

Base64decode = lsResult

End Function

%>

<%

Private Const BITS_TO_A_BYTE = 8

Private Const BYTES_TO_A_WORD = 4

Private Const BITS_TO_A_WORD = 32

Private m_lOnBits(30)

Private m_l2Power(30)

Dim Md5OLD

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 str2bin(varstr)

Dim varasc

Dim i

Dim varchar

Dim varlow

Dim varhigh

str2bin=""

For i=1 To Len(varstr)

varchar=mid(varstr,i,1)

varasc = Asc(varchar)

If varasc<0 Then

varasc = varasc + 65535

End If

If varasc>255 Then

varlow = Left(Hex(Asc(varchar)),2)

varhigh = right(Hex(Asc(varchar)),2)

str2bin = str2bin & chrB("&H" & varlow) & chrB("&H" & varhigh)

Else

str2bin = str2bin & chrB(AscB(varchar))

End If

Next

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 md5_F(x, y, z)

md5_F = (x And y) Or ((Not x) And z)

End Function

Private Function md5_G(x, y, z)

md5_G = (x And z) Or (y And (Not z))

End Function

Private Function md5_H(x, y, z)

md5_H = (x Xor y Xor z)

End Function

Private Function md5_I(x, y, z)

md5_I = (y Xor (x Or (Not z)))

End Function

Private Sub md5_FF(a, b, c, d, x, s, ac)

a = AddUnsigned(a, AddUnsigned(AddUnsigned(md5_F(b, c, d), x), ac))

a = RotateLeft(a, s)

a = AddUnsigned(a, b)

End Sub

Private Sub md5_GG(a, b, c, d, x, s, ac)

a = AddUnsigned(a, AddUnsigned(AddUnsigned(md5_G(b, c, d), x), ac))

a = RotateLeft(a, s)

a = AddUnsigned(a, b)

End Sub

Private Sub md5_HH(a, b, c, d, x, s, ac)

a = AddUnsigned(a, AddUnsigned(AddUnsigned(md5_H(b, c, d), x), ac))

a = RotateLeft(a, s)

a = AddUnsigned(a, b)

End Sub

Private Sub md5_II(a, b, c, d, x, s, ac)

a = AddUnsigned(a, AddUnsigned(AddUnsigned(md5_I(b, c, d), x), ac))

a = RotateLeft(a, s)

a = AddUnsigned(a, b)

End Sub

Private Function ConvertToWordArray(sMessage)

Dim lMessageLength

Dim lNumberOfWords

Dim lWordArray()

Dim lBytePosition

Dim lByteCount

Dim lWordCount

Const MODULUS_BITS = 512

Const CONGRUENT_BITS = 448

If Md5OLD = 1 Then

lMessageLength = Len(sMessage)

Else

lMessageLength = LenB(sMessage)

End If

lNumberOfWords = (((lMessageLength + ((MODULUS_BITS - CONGRUENT_BITS) \ BITS_TO_A_BYTE)) \ (MODULUS_BITS \ BITS_TO_A_BYTE)) + 1) * (MODULUS_BITS \ BITS_TO_A_WORD)

ReDim lWordArray(lNumberOfWords - 1)

lBytePosition = 0

lByteCount = 0

Do Until lByteCount >= lMessageLength

lWordCount = lByteCount \ BYTES_TO_A_WORD

lBytePosition = (lByteCount Mod BYTES_TO_A_WORD) * BITS_TO_A_BYTE

If Md5OLD = 1 Then

lWordArray(lWordCount) = lWordArray(lWordCount) Or LShift(Asc(Mid(sMessage, lByteCount + 1, 1)), lBytePosition)

Else

lWordArray(lWordCount) = lWordArray(lWordCount) Or LShift(AscB(MidB(sMessage, lByteCount + 1, 1)), lBytePosition)

End If

lByteCount = lByteCount + 1

Loop

lWordCount = lByteCount \ BYTES_TO_A_WORD

lBytePosition = (lByteCount Mod BYTES_TO_A_WORD) * BITS_TO_A_BYTE

lWordArray(lWordCount) = lWordArray(lWordCount) Or LShift(&H80, lBytePosition)

lWordArray(lNumberOfWords - 2) = LShift(lMessageLength, 3)

lWordArray(lNumberOfWords - 1) = RShift(lMessageLength, 29)

ConvertToWordArray = lWordArray

End Function

Private Function WordToHex(lValue)

Dim lByte

Dim lCount

For lCount = 0 To 3

lByte = RShift(lValue, lCount * BITS_TO_A_BYTE) And m_lOnBits(BITS_TO_A_BYTE - 1)

WordToHex = WordToHex & Right("0" & Hex(lByte), 2)

Next

End Function

Public Function MD5(sMessage,stype)

m_lOnBits(0) = CLng(1)

m_lOnBits(1) = CLng(3)

m_lOnBits(2) = CLng(7)

m_lOnBits(3) = CLng(15)

m_lOnBits(4) = CLng(31)

m_lOnBits(5) = CLng(63)

m_lOnBits(6) = CLng(127)

m_lOnBits(7) = CLng(255)

m_lOnBits(8) = CLng(511)

m_lOnBits(9) = CLng(1023)

m_lOnBits(10) = CLng(2047)

m_lOnBits(11) = CLng(4095)

m_lOnBits(12) = CLng(8191)

m_lOnBits(13) = CLng(16383)

m_lOnBits(14) = CLng(32767)

m_lOnBits(15) = CLng(65535)

m_lOnBits(16) = CLng(131071)

m_lOnBits(17) = CLng(262143)

m_lOnBits(18) = CLng(524287)

m_lOnBits(19) = CLng(1048575)

m_lOnBits(20) = CLng(2097151)

m_lOnBits(21) = CLng(4194303)

m_lOnBits(22) = CLng(8388607)

m_lOnBits(23) = CLng(16777215)

m_lOnBits(24) = CLng(33554431)

m_lOnBits(25) = CLng(67108863)

m_lOnBits(26) = CLng(134217727)

m_lOnBits(27) = CLng(268435455)

m_lOnBits(28) = CLng(536870911)

m_lOnBits(29) = CLng(1073741823)

m_lOnBits(30) = CLng(2147483647)

m_l2Power(0) = CLng(1)

m_l2Power(1) = CLng(2)

m_l2Power(2) = CLng(4)

m_l2Power(3) = CLng(8)

m_l2Power(4) = CLng(16)

m_l2Power(5) = CLng(32)

m_l2Power(6) = CLng(64)

m_l2Power(7) = CLng(128)

m_l2Power(8) = CLng(256)

m_l2Power(9) = CLng(512)

m_l2Power(10) = CLng(1024)

m_l2Power(11) = CLng(2048)

m_l2Power(12) = CLng(4096)

m_l2Power(13) = CLng(8192)

m_l2Power(14) = CLng(16384)

m_l2Power(15) = CLng(32768)

m_l2Power(16) = CLng(65536)

m_l2Power(17) = CLng(131072)

m_l2Power(18) = CLng(262144)

m_l2Power(19) = CLng(524288)

m_l2Power(20) = CLng(1048576)

m_l2Power(21) = CLng(2097152)

m_l2Power(22) = CLng(4194304)

m_l2Power(23) = CLng(8388608)

m_l2Power(24) = CLng(16777216)

m_l2Power(25) = CLng(33554432)

m_l2Power(26) = CLng(67108864)

m_l2Power(27) = CLng(134217728)

m_l2Power(28) = CLng(268435456)

m_l2Power(29) = CLng(536870912)

m_l2Power(30) = CLng(1073741824)

Dim x

Dim k

Dim AA

Dim BB

Dim CC

Dim DD

Dim a

Dim b

Dim c

Dim d

Const S11 = 7

Const S12 = 12

Const S13 = 17

Const S14 = 22

Const S21 = 5

Const S22 = 9

Const S23 = 14

Const S24 = 20

Const S31 = 4

Const S32 = 11

Const S33 = 16

Const S34 = 23

Const S41 = 6

Const S42 = 10

Const S43 = 15

Const S44 = 21

If Md5OLD = 1 Then

x = ConvertToWordArray(sMessage)

Else

x = ConvertToWordArray(str2bin(sMessage))

End If

a = &H67452301

b = &HEFCDAB89

c = &H98BADCFE

d = &H10325476

For k = 0 To UBound(x) Step 16

AA = a

BB = b

CC = c

DD = d

md5_FF a, b, c, d, x(k + 0), S11, &HD76AA478

md5_FF d, a, b, c, x(k + 1), S12, &HE8C7B756

md5_FF c, d, a, b, x(k + 2), S13, &H242070DB

md5_FF b, c, d, a, x(k + 3), S14, &HC1BDCEEE

md5_FF a, b, c, d, x(k + 4), S11, &HF57C0FAF

md5_FF d, a, b, c, x(k + 5), S12, &H4787C62A

md5_FF c, d, a, b, x(k + 6), S13, &HA8304613

md5_FF b, c, d, a, x(k + 7), S14, &HFD469501

md5_FF a, b, c, d, x(k + 8), S11, &H698098D8

md5_FF d, a, b, c, x(k + 9), S12, &H8B44F7AF

md5_FF c, d, a, b, x(k + 10), S13, &HFFFF5BB1

md5_FF b, c, d, a, x(k + 11), S14, &H895CD7BE

md5_FF a, b, c, d, x(k + 12), S11, &H6B901122

md5_FF d, a, b, c, x(k + 13), S12, &HFD987193

md5_FF c, d, a, b, x(k + 14), S13, &HA679438E

md5_FF b, c, d, a, x(k + 15), S14, &H49B40821

md5_GG a, b, c, d, x(k + 1), S21, &HF61E2562

md5_GG d, a, b, c, x(k + 6), S22, &HC040B340

md5_GG c, d, a, b, x(k + 11), S23, &H265E5A51

md5_GG b, c, d, a, x(k + 0), S24, &HE9B6C7AA

md5_GG a, b, c, d, x(k + 5), S21, &HD62F105D

md5_GG d, a, b, c, x(k + 10), S22, &H2441453

md5_GG c, d, a, b, x(k + 15), S23, &HD8A1E681

md5_GG b, c, d, a, x(k + 4), S24, &HE7D3FBC8

md5_GG a, b, c, d, x(k + 9), S21, &H21E1CDE6

md5_GG d, a, b, c, x(k + 14), S22, &HC33707D6

md5_GG c, d, a, b, x(k + 3), S23, &HF4D50D87

md5_GG b, c, d, a, x(k + 8), S24, &H455A14ED

md5_GG a, b, c, d, x(k + 13), S21, &HA9E3E905

md5_GG d, a, b, c, x(k + 2), S22, &HFCEFA3F8

md5_GG c, d, a, b, x(k + 7), S23, &H676F02D9

md5_GG b, c, d, a, x(k + 12), S24, &H8D2A4C8A

md5_HH a, b, c, d, x(k + 5), S31, &HFFFA3942

md5_HH d, a, b, c, x(k + 8), S32, &H8771F681

md5_HH c, d, a, b, x(k + 11), S33, &H6D9D6122

md5_HH b, c, d, a, x(k + 14), S34, &HFDE5380C

md5_HH a, b, c, d, x(k + 1), S31, &HA4BEEA44

md5_HH d, a, b, c, x(k + 4), S32, &H4BDECFA9

md5_HH c, d, a, b, x(k + 7), S33, &HF6BB4B60

md5_HH b, c, d, a, x(k + 10), S34, &HBEBFBC70

md5_HH a, b, c, d, x(k + 13), S31, &H289B7EC6

md5_HH d, a, b, c, x(k + 0), S32, &HEAA127FA

md5_HH c, d, a, b, x(k + 3), S33, &HD4EF3085

md5_HH b, c, d, a, x(k + 6), S34, &H4881D05

md5_HH a, b, c, d, x(k + 9), S31, &HD9D4D039

md5_HH d, a, b, c, x(k + 12), S32, &HE6DB99E5

md5_HH c, d, a, b, x(k + 15), S33, &H1FA27CF8

md5_HH b, c, d, a, x(k + 2), S34, &HC4AC5665

md5_II a, b, c, d, x(k + 0), S41, &HF4292244

md5_II d, a, b, c, x(k + 7), S42, &H432AFF97

md5_II c, d, a, b, x(k + 14), S43, &HAB9423A7

md5_II b, c, d, a, x(k + 5), S44, &HFC93A039

md5_II a, b, c, d, x(k + 12), S41, &H655B59C3

md5_II d, a, b, c, x(k + 3), S42, &H8F0CCC92

md5_II c, d, a, b, x(k + 10), S43, &HFFEFF47D

md5_II b, c, d, a, x(k + 1), S44, &H85845DD1

md5_II a, b, c, d, x(k + 8), S41, &H6FA87E4F

md5_II d, a, b, c, x(k + 15), S42, &HFE2CE6E0

md5_II c, d, a, b, x(k + 6), S43, &HA3014314

md5_II b, c, d, a, x(k + 13), S44, &H4E0811A1

md5_II a, b, c, d, x(k + 4), S41, &HF7537E82

md5_II d, a, b, c, x(k + 11), S42, &HBD3AF235

md5_II c, d, a, b, x(k + 2), S43, &H2AD7D2BB

md5_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

if stype=32 then

MD5 = LCase(WordToHex(a) & WordToHex(b) & WordToHex(c) & WordToHex(d))

else

MD5=LCase(WordToHex(b) & WordToHex(c)) 'I crop this to fit 16byte database password :D

end if

End Function

%>

<%

'-----------------------------------------------------------------------

'--- EMAIL郵件處理類模塊

'--- Copyright (c) 2004 Aspsky, Inc.

'--- Mail: Sunwin@artbbs.net http://www.aspsky.net
'--- 2004-12-18

'-----------------------------------------------------------------------

'--- 設置項

'-----------------------------------------------------------------------

'--- ServerLoginName 設置您的郵件服務器登錄名

'--- ServerLoginPass 設置登錄密碼

'--- SendSMTP 設置SMTP郵件服務器地址

'--- SendFromEmail 設置發件人的E-MAIL地址

'--- SendFromName 設置發送人名稱

'--- ContentType 設置郵件類型 默認：text/html

'--- CharsetType 設置編碼類型 默認：gb2312

'--- SendObject 設置選取組件 1=Jmail,2=Cdonts,3=Aspemail

'-----------------------------------------------------------------------

'--- 屬性

'-----------------------------------------------------------------------

'--- SendMail Email, Topic, MailBody 收件人地址，標題，郵件內容

'-----------------------------------------------------------------------

'--- 獲取信息

'-----------------------------------------------------------------------

'--- ErrCode 信息編號 0=正常

'--- Description 相應操作信息

'--- Count 發送郵件數

'-----------------------------------------------------------------------

Class Dv_SendMail

Public Count,ErrCode,ErrMsg

Private LoginName,LoginPass,SMTP,FromEmail,FromName,Object,Content_Type,Charset_Type

Private Obj,cdoConfig

Private Sub Class_Initialize()

Object = 0

Count = 0

ErrCode = 0

Content_Type = "text/html"

Charset_Type = "gb2312"

End Sub

Private Sub Class_Terminate()

If Isobject(Obj) Then

Set Obj = Nothing

End If

If IsObject(cdoConfig) Then

Set cdoConfig = Nothing

End If

End Sub

'設置您的郵件服務器登錄名

Public Property Let ServerLoginName(Byval Value)

LoginName = Value

End Property

'設置登錄密碼

Public Property Let ServerLoginPass(Byval Value)

LoginPass = Value

End Property

'設置SMTP郵件服務器地址

Public Property Let SendSMTP(Byval Value)

SMTP = Value

End Property

'設置發件人的E-MAIL地址

Public Property Let SendFromEmail(Byval Value)

FromEmail = Value

End Property

'設置發送人名稱

Public Property Let SendFromName(Byval Value)

FromName = Value

End Property

'設置郵件類型

Public Property Let ContentType(Byval Value)

Content_Type = Value

End Property

'設置編碼類型

Public Property Let CharsetType(Byval Value)

Charset_Type = Cstr(Value)

End Property

'獲取錯誤信息

Public Property Get Description()

Description = ErrMsg

End Property

'設置選取組件 SendObject 0=Jmail,1=Cdonts,2=Aspemail

Public Property Let SendObject(Byval Value)

Object = Value

On Error Resume Next

Select Case Object

Case 1

Set Obj = Server.CreateObject("JMail.Message")

Case 2

Set Obj = Server.CreateObject("CDONTS.NewMail")

Case 3

Set Obj = Server.CreateObject("Persits.MailSender")

Case 4

Set Obj = Server.CreateObject("CDO.Message") 'window 2003 new SendMailCom Object

Case Else

ErrNumber = 2

End Select

If Err<>0 Then

ErrNumber = 3

End If

End Property

Private Property Let ErrNumber(Byval Value)

ErrCode = Value

ErrMsg = ErrMsg & Msg

End Property

Private Function Msg()

Dim MsgValue

Select Case ErrCode

Case 1

MsgValue = "未選取郵件組件或服務器不支持該組件！"

Case 2

MsgValue = "所選的組件不存在！"

Case 3

MsgValue = "錯誤：服務器不支持該組件!"

Case 4

MsgValue = "發送失敗!"

Case Else

MsgValue = "正常。"

End Select

Msg = MsgValue

End Function

Public Sub SendMail(Byval Email,Byval Topic,Byval MailBody)

If ErrCode <> 0 Then

Exit Sub

End If

If Email="" or ISNull(Email) Then Exit Sub

If Object>0 Then

Select Case Object

Case 1

Jmail Email,Topic,MailBody

Case 2

Cdonts Email,Topic,Mailbody

Case 3

Aspemail Email,Topic,Mailbody

Case 4

CDOMessage Email,Topic,Mailbody

Case Else

ErrNumber = 2

End Select

Else

ErrNumber = 1

End If

End Sub

Private Sub Jmail(Email,Topic,Mailbody)

On Error Resume Next

Obj.Silent = True

Obj.Logging = True

Obj.Charset = Charset_Type

If Not(LoginName = "" Or LoginPass = "") Then

Obj.MailServerUserName = LoginName '您的郵件服務器登錄名

Obj.MailServerPassword = LoginPass '登錄密碼

End If

Obj.ContentType = Content_Type

Obj.Priority = 1

Obj.From = FromEmail

Obj.FromName = FromName

Obj.AddRecipient Email

Obj.Subject = Topic

Obj.Body = Mailbody

If Err<>0 Then

ErrMsg = ErrMsg & "發送失敗!原因：" & Err.Description

ErrNumber = 4

Else

Obj.Send (SMTP)

Obj.ClearRecipients()

If Err<>0 Then

ErrMsg = ErrMsg & "發送失敗!原因：" & Err.Description

ErrNumber = 4

Else

Count = Count + 1

ErrMsg = ErrMsg & "發送成功!"

End If

End If

End Sub

Private Sub Cdonts(Email,Topic,Mailbody)

On Error Resume Next

Obj.From = FromEmail

Obj.To = Email

Obj.Subject = Topic

Obj.BodyFormat = 0

Obj.MailFormat = 0

Obj.Body = Mailbody

If Err<>0 Then

ErrMsg = ErrMsg & "發送失敗!原因：" & Err.Description

ErrNumber = 4

Else

Obj.Send

If Err<>0 Then

ErrMsg = ErrMsg & "發送失敗!原因：" & Err.Description

ErrNumber = 4

Else

Count = Count + 1

ErrMsg = ErrMsg & "發送成功!"

End If

End If

End Sub

Private Sub Aspemail(Email,Topic,Mailbody)

On Error Resume Next

Obj.Charset = Charset_Type

Obj.IsHTML = True

Obj.username = LoginName '服務器上有效的用戶名

Obj.password = LoginPass '服務器上有效的密碼

Obj.Priority = 1

Obj.Host = SMTP

'Obj.Port = 25 ' 該項可選.端口25是默認值

Obj.From = FromEmail

Obj.FromName = FromName ' 該項可選

Obj.AddAddress Email,Email

Obj.Subject = Topic

Obj.Body = Mailbody

If Err<>0 Then

ErrMsg = ErrMsg & "發送失敗!原因：" & Err.Description

ErrNumber = 4

Else

Obj.Send

If Err<>0 Then

ErrMsg = ErrMsg & "發送失敗!原因：" & Err.Description

ErrNumber = 4

Else

Count = Count + 1

ErrMsg = ErrMsg & "發送成功!"

End If

End If

End Sub

Private Sub CDOMessage(Email,Topic,Mailbody)

On Error Resume Next

If Not IsObject(cdoConfig) Then

Call CreatCDOConfig()

End If

Set Obj = Server.CreateObject("CDO.Message")

With Obj

Set .Configuration = cdoConfig

'.From = FromEmail

.To = Email

.Subject = Topic

.TextBody = Mailbody

.Send

End With

If Err<>0 Then

ErrMsg = ErrMsg & "發送失敗!原因：" & Err.Description

ErrNumber = 4

Else

Count = Count + 1

ErrMsg = ErrMsg & "發送成功!"

End If

End Sub

Private Sub CreatCDOConfig()

On Error Resume Next

Dim Sch

sch = "http://schemas.microsoft.com/cdo/configuration/"

Set cdoConfig = Server.CreateObject("CDO.Configuration")

With cdoConfig.Fields

.Item(sch & "smtpserver") = SMTP

'.Item(sch & "smtpserverport") = 25

.Item(sch & "sendusing") = 2 'cdoSendUsingPort CdoSendUsing enum value = 2

.Item(sch & "smtpaccountname") = FromName '"My Name"

.Item(sch & "sendemailaddress") = FromEmail '"""MySelf"" <example@example.com>"

.Item(sch & "smtpuserreplyemailaddress") = 25 '"""Another"" <another@example.com>"

'.Item(sch & "smtpauthenticate") = cdoBasic

.Item(sch & "sendusername") = LoginName

.Item(sch & "sendpassword") = LoginPass

.update

End With

If Err<>0 Then

ErrMsg = ErrMsg & "發送失敗!原因：" & Err.Description

ErrNumber = 4

End If

End Sub

End Class

%>

var dv_ajax_debug_mode = false;

function dvajax_debug(text) {

if (dv_ajax_debug_mode)

alert("RSD: " + text);

}

function dvajax_init_object() {

dvajax_debug("dvajax_init_object() called..");

var RetValue;

try {

RetValue = new ActiveXObject("Msxml2.XMLHTTP");

} catch (e) {

try {

RetValue = new ActiveXObject("Microsoft.XMLHTTP");

} catch (oc) {

RetValue = null;

}

}

if(!RetValue && typeof XMLHttpRequest != "undefined")

RetValue = new XMLHttpRequest();

if (!RetValue)

dvajax_debug("Could not create connection object.");

return RetValue;

}

function dvajax_run(func_name,func_obj, args) {

var i, x, n;

var uri;

var post_data;

uri = "ajax_check.asp";

if (dvajax_request_type == "GET") {

if (uri.indexOf("?") == -1)

uri = uri + "?rs=" + func_name;

else

uri = uri + "&rs=" + func_name;

for (i = 0; i < args.length-1; i++)

uri = uri + "&rsargs[]=" + args[i];

uri = uri + "&rsrnd=" + new Date().getTime();

post_data = null;

} else {

post_data = "rs=" + func_name;

for (i = 0; i < args.length-1; i++)

post_data = post_data + "&rsargs[]=" + urlencode(args[i]);

}

x = dvajax_init_object();

x.open(dvajax_request_type, uri, true);

if (dvajax_request_type == "POST") {

x.setRequestHeader("Method", "POST " + uri + " HTTP/1.1");

x.setRequestHeader("Content-Type", "application/x-www-form-urlencoded");

}

x.onreadystatechange = function() {

if (x.readyState != 4)

return;

dvajax_debug("received " + x.responseText);

var status;

var data;

status = x.responseText.charAt(0);

datacache = x.responseText.substring(0);

data = unescape(datacache);

if (status == "-")

alert("Error: " + data);

else

args[args.length-1](func_obj,data);

}

x.send(post_data);

dvajax_debug(func_name + " uri = " + uri + "/post = " + post_data);

dvajax_debug(func_name + " waiting..");

delete x;

}

function obj_getbyid(id) {

itm = null;

if (document.getElementById) {

itm = document.getElementById(id);

} else if (document.all) {

itm = document.all[id];

} else if (document.layers) {

itm = document.layers[id];

}

return itm;

}

function dv_ajaxcheck(seltype,objid){

var objname = obj_getbyid(objid).value;

if (objname){

x_checkdata(seltype,objid,objname,checkuser_cb);

}

}

function checkuser_cb(c_type,data){

var isok_username = obj_getbyid("isok_"+c_type);

if (isok_username)

{

isok_username.innerHTML = " "+data;

}

}

function x_checkdata(x_seltype,x_obj) {

dvajax_run(x_seltype,x_obj,x_checkdata.arguments);

}

function urlencode(text){

text = text.toString();

var matches = text.match(/[\x90-\xFF]/g);

if (matches)

{

for (var matchid = 0; matchid < matches.length; matchid++)

{

var char_code = matches[matchid].charCodeAt(0);

text = text.replace(matches[matchid], '%u00' + (char_code & 0xFF).toString(16).toUpperCase());

}

}

return escape(text).replace(/\+/g, "%2B");

}

var RegCheck = {

passValue : new Array(),

pass : function(v,Objid,t){

var isok_pass = obj_getbyid("isok_"+Objid);

RegCheck.passValue[t] = v;

if (v.length<6||v.length>10){

isok_pass.innerHTML = err_msg("密碼不能少於6位或多於10位");

return false;

}else{

isok_pass.innerHTML = suc_msg("符合要求");

}

if (t==0){

SetPwdStrengthEx(v);

}else{

if (RegCheck.passValue.length==2){

if (RegCheck.passValue[0]==RegCheck.passValue[1]){

isok_pass.innerHTML = suc_msg("符合要求");

}else{

isok_pass.innerHTML = err_msg("重復輸入密碼不符");

return false;

}

}else

{

isok_pass.innerHTML = err_msg("重復輸入密碼不符");

return false;

}

}

return true;

},

Value : function(v,Objid){

var isok_pass = obj_getbyid("isok_"+Objid);

if (v==''){

isok_pass.innerHTML = err_msg("必填內容，不能為空");

return false;

}else{

return true;

}

}

}

//錯誤提示信息

function err_msg(msg){

return "<img src='"+forum_picurl+"/note_error.gif' border='0'/> <span class='redfont'>"+msg+"</span>";

}

//成功提示信息

function suc_msg(msg){

return "<img src='"+forum_picurl+"/note_ok.gif' border='0'/> <span class='bluefont'>"+msg+"</span>";

}

//檢查密碼強弱

function pse_a1(j,b){

this.j=j;this.b=b;

};

function pse_a7(c,j){

var b=false;

switch(j){

case 0:

if((c>='A')&&(c<='Z')){

b=true;

};

break;

case 1:

if((c>='a')&&(c<='z')){

b=true;

};

break;

case 2:

if((c>='0')&&(c<='9')){

b=true;

};

break;

case 3:

if("!@#$%^&*()_+-='\";:[{]}\|.>,</?`~".indexOf(c)>=0){

b=true;

};

break;

case 4:

if(pse_a7(c,0)||pse_a7(c,1)){

b=true;

};

break;

default:break;

};

return b;

};

function pse_a8(e,g){

if((e==null)||isNaN(g)){

return false;

}else if(e.length<g){

return false;

};

return true;

};

function pse_a10(e,f){

var i=0;

var jj=new Array(new pse_a1(0,false),new pse_a1(1,false),new pse_a1(2,false),new pse_a1(3,false));

if((e==null)||isNaN(f)){

return false;

};

for(var k=0;k<e.length;k++){

for(var d=0;d<jj.length;d++){

if(!jj[d].b&&pse_a7(e.charAt(k),jj[d].j)){

jj[d].b=true;break;

};

};

};

for(var d=0;d<jj.length;d++){if(jj[d].b){i++;};};if(i<f){return false;};return true;};function pse_a3(h){return(pse_a8(h,"7")&&pse_a10(h,"3"));};function pse_a2(h){return(pse_a8(h,"7")&&pse_a10(h,"2"));};function pse_a4(h){return(pse_a8(h,"5")||(!pse_a8(h,"0")));};function pse_a6(q){return document.getElementById(q);};

function SetPwdStrengthEx(o){

if(pse_a3(o)){

pse_a5(3,'pse04');

}

else if(pse_a2(o)){

pse_a5(2,'pse03');

}else if(pse_a4(o)){pse_a5(1,'pse02');

}else{

pse_a5(0,'pse01');

};

};

function pse_a5(m,p){if(m>3){m=3;};for(var n=0;n<4;n++){var l="pse01";if(n<=m){l=p;};if(n>0){pse_a6("idSM"+n).className=l;};pse_a6("idSMT"+n).style.display=((n==m)?"inline":"none");};};