screen.width-333)this.width=screen.width-333"">

screen.width-333)this.width=screen.width-333"">

[全屏欣赏]

[全屏欣赏]

") fString = Replace(fString, CHR(10), "
") dvHTMLEncode = fString end function function dvHTMLCode(byval fString) if isnull(fString) or trim(fString)="" then dvHTMLCode="" exit function end if fString = replace(fString, ">", ">") fString = replace(fString, "<", "<") fString = Replace(fString, " "," ") fString = Replace(fString, """, CHR(34)) fString = Replace(fString, "'", CHR(39)) fString = Replace(fString, "

",CHR(10) & CHR(10)) fString = Replace(fString, "
", CHR(10)) dvHTMLCode = fString end function function nohtml(byval str) if isnull(str) or trim(str)="" then nohtml="" exit function end if dim re Set re=new RegExp re.IgnoreCase =true re.Global=True re.Pattern="(\<.[^\<]*\>)" str=re.replace(str," ") re.Pattern="(\<\/[^\<]*\>)" str=re.replace(str," ") set re=nothing str=replace(str,chr(34),"") str=replace(str,"'","") nohtml=str 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 Md5OLD = 1 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 %> <% Dim Action, FoundErr, ErrMsg, ComeUrl Dim strInstallDir Dim Site_Sn '定义系统识别码 '定义用户相关的变量 Dim UserLogined, GroupID, GroupName, GroupType, Discount_Member, IsOffer, LoginTimes, RegTime, JoinTime, LastLoginTime, LastLoginIP Dim UserID, ClientID, CompanyID, ContacterID, UserType, UserName, email, Balance, UserPoint, UserExp, ValidNum, ValidDays, SpecialPermission, UserSetting, ChargeType Dim UnsignedItems, UnreadMsg, arrClass_Input, arrClass_View Dim DefaultTemplateProjectName If Request("ComeUrl") = "" Then ComeUrl = Trim(Request.ServerVariables("HTTP_REFERER")) Else ComeUrl = Trim(Request("ComeUrl")) End If Action = Trim(Request("Action")) FoundErr = False ErrMsg = "" If Right(InstallDir, 1) <> "/" Then strInstallDir = InstallDir & "/" Else strInstallDir = InstallDir End If Site_Sn = Replace(Replace(LCase(Request.ServerVariables("SERVER_NAME") & InstallDir), "/", ""), ".", "") '************************************************** '函数名：gotTopic '作 用：截字符串，汉字一个算两个字符，英文算一个字符 '参 数：str ----原字符串 ' strlen ----截取长度 '返回值：截取后的字符串 '************************************************** Function gotTopic(ByVal str, ByVal strlen) If str = "" Then gotTopic = "" Exit Function End If Dim l, t, c, i, strTemp str = Replace(Replace(Replace(Replace(str, " ", " "), """, Chr(34)), ">", ">"), "<", "<") l = Len(str) t = 0 strTemp = str strlen = CLng(strlen) For i = 1 To l c = Abs(Asc(Mid(str, i, 1))) If c > 255 Then t = t + 2 Else t = t + 1 End If If t >= strlen Then strTemp = Left(str, i) Exit For End If Next If strTemp <> str Then strTemp = strTemp & "…" End If gotTopic = Replace(Replace(Replace(Replace(strTemp, " ", " "), Chr(34), """), ">", ">"), "<", "<") End Function '************************************************** '函数名：JoinChar '作 用：向地址中加入 ? 或 & '参 数：strUrl ----网址 '返回值：加了 ? 或 & 的网址 '************************************************** Function JoinChar(ByVal strUrl) If strUrl = "" Then JoinChar = "" Exit Function End If If InStr(strUrl, "?") < Len(strUrl) Then If InStr(strUrl, "?") > 1 Then If InStr(strUrl, "&") < Len(strUrl) Then JoinChar = strUrl & "&" Else JoinChar = strUrl End If Else JoinChar = strUrl & "?" End If Else JoinChar = strUrl End If End Function '************************************************** '函数名：ShowPage '作 用：显示“上一页 下一页”等信息 '参 数：sFileName ----链接地址 ' TotalNumber ----总数量 ' MaxPerPage ----每页数量 ' CurrentPage ----当前页 ' ShowTotal ----是否显示总数量 ' ShowAllPages ---是否用下拉列表显示所有页面以供跳转。 ' strUnit ----计数单位 ' ShowMaxPerPage ----是否显示每页信息量选项框 '返回值：“上一页 下一页”等信息的HTML代码 '************************************************** Function ShowPage(sfilename, totalnumber, MaxPerPage, CurrentPage, ShowTotal, ShowAllPages, strUnit, ShowMaxPerPage) Dim TotalPage, strTemp, strUrl, i If totalnumber = 0 Or MaxPerPage = 0 Or IsNull(MaxPerPage) Then ShowPage = "" Exit Function End If If totalnumber Mod MaxPerPage = 0 Then TotalPage = totalnumber \ MaxPerPage Else TotalPage = totalnumber \ MaxPerPage + 1 End If If CurrentPage > TotalPage Then CurrentPage = TotalPage strTemp = "

" If ShowTotal = True Then strTemp = strTemp & "共 " & totalnumber & " " & strUnit & "  " End If If ShowMaxPerPage = True Then strUrl = JoinChar(sfilename) & "MaxPerPage=" & MaxPerPage & "&" Else strUrl = JoinChar(sfilename) End If If CurrentPage = 1 Then strTemp = strTemp & "首页 上一页 " Else strTemp = strTemp & "首页 " strTemp = strTemp & "上一页 " End If If CurrentPage >= TotalPage Then strTemp = strTemp & "下一页 尾页" Else strTemp = strTemp & "下一页 " strTemp = strTemp & "尾页" End If strTemp = strTemp & " 页次：" & CurrentPage & "/" & TotalPage & "页 " If ShowMaxPerPage = True Then strTemp = strTemp & " " & strUnit & "/页" Else strTemp = strTemp & " " & MaxPerPage & "" & strUnit & "/页" End If If ShowAllPages = True Then If TotalPage > 20 Then strTemp = strTemp & "  转到第页" Else strTemp = strTemp & " 转到：" For i = 1 To TotalPage strTemp = strTemp & "第" & i & "页" Next strTemp = strTemp & "" End If End If strTemp = strTemp & "

" ShowPage = strTemp End Function '************************************************** '函数名：IsObjInstalled '作 用：检查组件是否已经安装 '参 数：strClassString ----组件名 '返回值：True ----已经安装 ' False ----没有安装 '************************************************** Function IsObjInstalled(strClassString) On Error Resume Next IsObjInstalled = False Err = 0 Dim xTestObj Set xTestObj = Server.CreateObject(strClassString) If 0 = Err Then IsObjInstalled = True Set xTestObj = Nothing Err = 0 End Function '************************************************** '函数名：strLength '作 用：求字符串长度。汉字算两个字符，英文算一个字符。 '参 数：str ----要求长度的字符串 '返回值：字符串长度 '************************************************** Function strLength(str) On Error Resume Next Dim WINNT_CHINESE WINNT_CHINESE = (Len("中国") = 2) If WINNT_CHINESE Then Dim l, t, c Dim i l = Len(str) t = l For i = 1 To l c = Asc(Mid(str, i, 1)) If c < 0 Then c = c + 65536 If c > 255 Then t = t + 1 End If Next strLength = t Else strLength = Len(str) End If If Err.Number <> 0 Then Err.Clear End Function '************************************************** '函数：FoundInArr '作 用：检查一个数组中所有元素是否包含指定字符串 '参 数：strArr ----存储数据数据的字串 ' strToFind ----要查找的字符串 ' strSplit ----数组的分隔符 '返回值：True,False '************************************************** Function FoundInArr(strArr, strToFind, strSplit) Dim arrTemp, i FoundInArr = False If InStr(strArr, strSplit) > 0 Then arrTemp = Split(strArr, strSplit) For i = 0 To UBound(arrTemp) If LCase(Trim(arrTemp(i))) = LCase(Trim(strToFind)) Then FoundInArr = True Exit For End If Next Else If LCase(Trim(strArr)) = LCase(Trim(strToFind)) Then FoundInArr = True End If End If End Function '************************************************** '过程名：WriteErrMsg '作 用：显示错误提示信息 '参 数：无 '************************************************** Sub WriteErrMsg(sErrMsg, sComeUrl) Dim strErr strErr = strErr & "" & vbCrLf strErr = strErr & "

" & vbCrLf strErr = strErr & "" & vbCrLf strErr = strErr & " " & vbCrLf strErr = strErr & " " & vbCrLf strErr = strErr & " " & vbCrLf strErr = strErr & "

错误信息

产生错误的可能原因：" & sErrMsg & "

" If sComeUrl <> "" Then strErr = strErr & "<< 返回上一页" Else strErr = strErr & "【关闭】" End If strErr = strErr & "

" & vbCrLf strErr = strErr & "" & vbCrLf Response.Write strErr End Sub '************************************************** '过程名：WriteSuccessMsg '作 用：显示成功提示信息 '参 数：无 '************************************************** Sub WriteSuccessMsg(sSuccessMsg, sComeUrl) Dim strSuccess strSuccess = strSuccess & "" & vbCrLf strSuccess = strSuccess & "

" & vbCrLf strSuccess = strSuccess & "" & vbCrLf strSuccess = strSuccess & " " & vbCrLf strSuccess = strSuccess & " " & vbCrLf strSuccess = strSuccess & " " & vbCrLf strSuccess = strSuccess & "

恭喜你！

" & sSuccessMsg & "

" If sComeUrl <> "" Then strSuccess = strSuccess & "<< 返回上一页" Else strSuccess = strSuccess & "【关闭】" End If strSuccess = strSuccess & "

" & vbCrLf strSuccess = strSuccess & "" & vbCrLf Response.Write strSuccess End Sub '************************************************** '函数名：ReplaceBadChar '作 用：过滤非法的SQL字符 '参 数：strChar-----要过滤的字符 '返回值：过滤后的字符 '************************************************** Function ReplaceBadChar(strChar) If strChar = "" Or IsNull(strChar) Then ReplaceBadChar = "" Exit Function End If Dim strBadChar, arrBadChar, tempChar, i strBadChar = "+,',--,%,^,&,?,(,),<,>,[,],{,},/,\,;,:," & Chr(34) & "," & Chr(0) & "" arrBadChar = Split(strBadChar, ",") tempChar = strChar For i = 0 To UBound(arrBadChar) tempChar = Replace(tempChar, arrBadChar(i), "") Next tempChar = Replace(tempChar, "@@", "@") ReplaceBadChar = tempChar End Function Function PE_CLng(ByVal str1) If IsNumeric(str1) Then PE_CLng = CLng(str1) Else PE_CLng = 0 End If End Function Function PE_CDbl(ByVal str1) If IsNumeric(str1) Then PE_CDbl = CDbl(str1) Else PE_CDbl = 0 End If End Function Function PE_CDate(ByVal str1) If IsDate(str1) Then PE_CDate = CDate(str1) Else PE_CDate = Date End If End Function '************************************************** '函数名：IsValidEmail '作 用：检查Email地址合法性 '参 数：email ----要检查的Email地址 '返回值：True ----Email地址合法 ' False ----Email地址不合法 '************************************************** Function IsValidEmail(email) Dim names, name, i, c IsValidEmail = True names = Split(email, "@") If UBound(names) <> 1 Then IsValidEmail = False Exit Function End If For Each name In names If Len(name) <= 0 Then IsValidEmail = False Exit Function End If For i = 1 To Len(name) c = LCase(Mid(name, i, 1)) If InStr("abcdefghijklmnopqrstuvwxyz_-.", c) <= 0 And Not IsNumeric(c) Then IsValidEmail = False Exit Function End If Next If Left(name, 1) = "." Or Right(name, 1) = "." Then IsValidEmail = False Exit Function End If Next If InStr(names(1), ".") <= 0 Then IsValidEmail = False Exit Function End If i = Len(names(1)) - InStrRev(names(1), ".") If i <> 2 And i <> 3 And i <> 4 Then IsValidEmail = False Exit Function End If If InStr(email, "..") > 0 Then IsValidEmail = False End If End Function '得到数组中某个元素的值 Public Function GetArrItem(ByVal arrTemp, ByVal ItemIndex) If Not IsArray(arrTemp) Then GetArrItem = "" Exit Function End If ItemIndex = PE_CLng(ItemIndex) If ItemIndex < 0 Or ItemIndex > UBound(arrTemp) Then GetArrItem = "" Exit Function End If Dim strTemp strTemp = arrTemp(ItemIndex) If InStr(strTemp, "|") > 0 Then GetArrItem = Left(strTemp, InStr(strTemp, "|") - 1) Else GetArrItem = strTemp End If End Function '把数组变成下拉列表项目 Public Function Array2Option(ByVal arrTemp, ByVal ID) Dim strOption, i, arrValue strOption = " " ID = PE_CLng(ID) For i = 0 To UBound(arrTemp) arrValue = Split(arrTemp(i), "|") If CLng(arrValue(1)) = 1 Then If ID > -1 Then If i = ID Then strOption = strOption & "" & arrValue(0) & "" Else strOption = strOption & "" & arrValue(0) & "" End If Else If CLng(arrValue(2)) = 1 Then strOption = strOption & "" & arrValue(0) & "" Else strOption = strOption & "" & arrValue(0) & "" End If End If End If Next Array2Option = strOption End Function Function GetRndPassword(PasswordLen) Dim Ran, i, strPassword strPassword = "" For i = 1 To PasswordLen Randomize Ran = CInt(Rnd * 2) Randomize If Ran = 0 Then Ran = CInt(Rnd * 25) + 97 strPassword = strPassword & UCase(Chr(Ran)) ElseIf Ran = 1 Then Ran = CInt(Rnd * 9) strPassword = strPassword & Ran ElseIf Ran = 2 Then Ran = CInt(Rnd * 25) + 97 strPassword = strPassword & Chr(Ran) End If Next GetRndPassword = strPassword End Function Function GetScriptPath(ByVal ScriptName, ParentLevel) Dim i GetScriptPath = "/" If ScriptName = "" Or IsNull(ScriptName) Then Exit Function If ParentLevel > 1 Then ParentLevel = 1 If ParentLevel = 0 Then GetScriptPath = Left(ScriptName, InStrRev(ScriptName, "/")) ElseIf ParentLevel = 1 Then i = InStrRev(ScriptName, "/") - 1 If i < 1 Then i = 1 GetScriptPath = Left(ScriptName, InStrRev(ScriptName, "/", i)) End If If Right(GetScriptPath, 1) <> "/" Then GetScriptPath = GetScriptPath & "/" End Function '判断当前访问者是否已经登录，若已登录，则读取数据并做必要赋值 Function CheckUserLogined() Dim UserPassword, LastPassword Dim rsUser, sqlUser Dim rsConfig UserName = ReplaceBadChar(Trim(Request.Cookies(Site_Sn)("UserName"))) UserPassword = ReplaceBadChar(Trim(Request.Cookies(Site_Sn)("UserPassword"))) LastPassword = ReplaceBadChar(Trim(Request.Cookies(Site_Sn)("LastPassword"))) UserID = 0 ClientID = 0 CompanyID = 0 ContacterID = 0 UserType = 0 GroupID = 0 GroupType = 0 GroupName = "游客" Discount_Member = 100 Balance = 0 UserPoint = 0 UserExp = 0 IsOffer = "否" If (UserName = "" Or UserPassword = "" Or LastPassword = "") Then CheckUserLogined = False Exit Function End If sqlUser = "SELECT U.*,G.GroupName,G.GroupType,G.GroupSetting,G.arrClass_Input as G_arrClass_Input,G.arrClass_View as G_arrClass_View FROM PE_User U inner join PE_UserGroup G on U.GroupID=G.GroupID WHERE" sqlUser = sqlUser & " U.UserName='" & UserName & "' AND U.UserPassword='" & UserPassword & "' AND U.LastPassword='" & LastPassword & "' and IsLocked=" & PE_False & "" Set rsUser = Conn.Execute(sqlUser) If rsUser.EOF And rsUser.BOF Then CheckUserLogined = False Else CheckUserLogined = True UserID = rsUser("UserID") ClientID = rsUser("ClientID") CompanyID = rsUser("CompanyID") ContacterID = rsUser("ContacterID") UserType = rsUser("UserType") UserName = rsUser("UserName") UserPassword = rsUser("UserPassword") LastPassword = rsUser("LastPassword") email = rsUser("Email") Balance = PE_CDbl(rsUser("Balance")) UserPoint = PE_CLng(rsUser("UserPoint")) UserExp = PE_CLng(rsUser("UserExp")) ValidNum = rsUser("ValidNum") LoginTimes = rsUser("LoginTimes") ValidDays = ChkValidDays(rsUser("ValidNum"), rsUser("ValidUnit"), rsUser("BeginTime")) GroupID = rsUser("GroupID") GroupName = rsUser("GroupName") GroupType = rsUser("GroupType") SpecialPermission = rsUser("SpecialPermission") If SpecialPermission = True Then UserSetting = Split(rsUser("UserSetting") & ",0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0", ",") arrClass_Input = rsUser("arrClass_Input") arrClass_View = rsUser("arrClass_View") Else UserSetting = Split(rsUser("GroupSetting") & ",0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0", ",") arrClass_Input = rsUser("G_arrClass_Input") arrClass_View = rsUser("G_arrClass_View") End If Discount_Member = PE_CDbl(UserSetting(11)) If PE_CLng(UserSetting(12)) = 1 Then IsOffer = "是" Else IsOffer = "否" End If ChargeType = PE_CLng(UserSetting(14)) UnsignedItems = rsUser("UnsignedItems") UnreadMsg = PE_CLng(rsUser("UnreadMsg")) RegTime = rsUser("RegTime") JoinTime = rsUser("JoinTime") LoginTimes = rsUser("LoginTimes") LastLoginTime = rsUser("LastLoginTime") LastLoginIP = rsUser("LastLoginIP") If PresentExpPerLogin > 0 Then If DateDiff("D", rsUser("LastPresentTime"), Now()) > 0 Then Conn.Execute ("update PE_User set UserExp=UserExp+" & PresentExpPerLogin & ",LastPresentTime=" & PE_Now & " where UserID=" & UserID & "") End If End If If PE_CLng(Session("UserID")) = 0 Then Conn.Execute ("update PE_User set LastLoginIP='" & UserTrueIP & "',LastLoginTime=" & PE_Now & ",LoginTimes=LoginTimes+1 where UserID=" & UserID & "") Session("UserID") = UserID End If End If Set rsUser = Nothing DefaultTemplateProjectName = GetDefaultTemplateProjectName() End Function Function GetDefaultTemplateProjectName() Dim rsProject, strProjectName Set rsProject = Conn.Execute("select TemplateProjectName from PE_TemplateProject where IsDefault=" & PE_True) If Not rsProject.EOF Then strProjectName = rsProject("TemplateProjectName") Else strProjectName = "动易2006海蓝方案" End If Set rsProject = Nothing GetDefaultTemplateProjectName = strProjectName End Function Function GetClientName(ClientID) If ClientID <= 0 Then GetClientName = "" Exit Function End If Dim rsClient Set rsClient = Conn.Execute("select ClientName from PE_Client where ClientID=" & ClientID & "") If rsClient.BOF And rsClient.EOF Then GetClientName = "" Else GetClientName = rsClient(0) End If rsClient.Close Set rsClient = Nothing End Function Function GetGroupName(iGroupID) Dim rsGroup Set rsGroup = Conn.Execute("select GroupName from PE_UserGroup where GroupID=" & iGroupID & "") If rsGroup.BOF And rsGroup.EOF Then GetGroupName = "未知" Else GetGroupName = rsGroup(0) End If Set rsGroup = Nothing End Function Function CheckBadChar(strChar) Dim strBadChar, arrBadChar, i strBadChar = "@@,+,',--,%,^,&,?,(,),<,>,[,],{,},/,\,;,:," & Chr(34) & "" arrBadChar = Split(strBadChar, ",") If strChar = "" Then CheckBadChar = False Else For i = 0 To UBound(arrBadChar) If InStr(strChar, arrBadChar(i)) > 0 Then CheckBadChar = False Exit Function End If Next End If CheckBadChar = True End Function Function ReplaceUrlBadChar(strChar) If strChar = "" Or IsNull(strChar) Then ReplaceUrlBadChar = "" Exit Function End If Dim strBadChar, arrBadChar, tempChar, i strBadChar = "+,',--,(,),<,>,[,],{,},\,;," & Chr(34) & "," & Chr(0) & "" arrBadChar = Split(strBadChar, ",") tempChar = strChar For i = 0 To UBound(arrBadChar) tempChar = Replace(tempChar, arrBadChar(i), "") Next tempChar = Replace(tempChar, "@@", "@") ReplaceUrlBadChar = tempChar End Function Function GetNewID(SheetName, FieldName) Dim mrs Set mrs = Conn.Execute("select max(" & FieldName & ") from " & SheetName & "") If IsNull(mrs(0)) Then GetNewID = 1 Else GetNewID = mrs(0) + 1 End If Set mrs = Nothing End Function Function GetArrFromDictionary(strTableName, strFieldName) Dim rsDictionary Set rsDictionary = Conn.Execute("select FieldValue from PE_Dictionary where TableName='" & strTableName & "' and FieldName='" & strFieldName & "'") If rsDictionary.BOF And rsDictionary.EOF Then GetArrFromDictionary = "" Else GetArrFromDictionary = rsDictionary(0) End If Set rsDictionary = Nothing End Function Function ChkValidDays(iValidNum, iValidUnit, iBeginTime) If (iValidNum = "" Or IsNumeric(iValidNum) = False Or iValidUnit = "" Or IsNumeric(iValidUnit) = False Or iBeginTime = "" Or IsDate(iBeginTime) = False) Then ChkValidDays = 0 Exit Function End If Dim tmpDate, arrInterval arrInterval = Array("h", "D", "m", "yyyy") If iValidNum = -1 Then ChkValidDays = 99999 Else tmpDate = DateAdd(arrInterval(iValidUnit), iValidNum, iBeginTime) ChkValidDays = DateDiff("D", Date, tmpDate) End If End Function '************************************************** '函数名：PE_ServerHTMLEncode '作 用：显示HTML代码 '参 数：Content ---- 要输出HTML的字符串 '返回值：处理后的字符串 '************************************************** Function PE_ServerHTMLEncode(ByVal Content) If IsNull(Content) Then PE_ServerHTMLEncode = "" Else PE_ServerHTMLEncode = Server.HTMLEncode(Content) End If End Function '************************************************** '函数名：nohtml '作 用：过滤html 元素 '参 数：str ---- 要过滤字符 '返回值：没有html 的字符 '************************************************** Public Function nohtml(ByVal str) If IsNull(str) Or Trim(str) = "" Then nohtml = "" Exit Function End If Dim re Set re = New RegExp re.IgnoreCase = True re.Global = True re.Pattern = "(\<.[^\<]*\>)" str = re.Replace(str, " ") re.Pattern = "(\<\/[^\<]*\>)" str = re.Replace(str, " ") Set re = Nothing str = Replace(str, "'", "") str = Replace(str, Chr(34), "") nohtml = str End Function '================================================= '函数名：ReplaceBadUrl '作 用：过滤非法Url地址函数 '================================================= Public Function ReplaceBadUrl(ByVal strContent) Dim regEx,Matches,Match Set regEx = New RegExp regEx.IgnoreCase = True regEx.Global = True regEx.Pattern = "(a|%61|%41)(d|%64|%44)(m|%6D|4D)(i|%69|%49)(n|%6E|%4E)(\_|%5F)(.*?)(.|%2E)(a|%61|%41)(s|%73|%53)(p|%70|%50)" Set Matches = regEx.Execute(strContent) For Each Match In Matches strContent = Replace(strContent, Match.Value, "") Next regEx.Pattern = "(u|%75|%55)(s|%73|%53)(e|%65|%45)(r|%72|%52)(\_|%5F)(.*?)(.|%2E)(a|%61|%41)(s|%73|%53)(p|%70|%50)" Set Matches = regEx.Execute(strContent) For Each Match In Matches strContent = Replace(strContent, Match.Value, "") Next Set regEx = Nothing ReplaceBadUrl = strContent End Function %> <% dim BeginTime,EndTime dim PageTitle,strPath,strPageTitle dim ItemCount_Channel,ItemChecked_Channel,CommentCount_Channel,SpecialCount_Channel,HitsCount_Channel dim FileName,strFileName dim totalPut,CurrentPage,TotalPages BeginTime=Timer UserLogined=CheckUserLogined() strPath= " 您现在的位置： " & SiteName & "" strPageTitle= SiteTitle CurrentPage=trim(request("page")) if CurrentPage="" then CurrentPage=1 else CurrentPage=Clng(CurrentPage) end if if ShowSiteChannel=True then call GetChannel_All() else call GetChannel_Current() end if sub GetChannel_All() if ChannelID=0 then strChannel= "| 首页 | " else strChannel= "| 首页 | " end if sqlChannel="select * from PE_Channel order by OrderID" set rsChannel=server.CreateObject("adodb.recordset") rsChannel.open sqlChannel,conn,1,1 do while not rsChannel.eof if rsChannel("ChannelID")=ChannelID then if rsChannel("Disabled")=True then response.write "此频道已经被管理员禁用！" response.end end if ChannelName=rsChannel("ChannelName") ChannelDir=rsChannel("ChannelDir") ChannelShortName=rsChannel("ChannelShortName") ShowChannelName=rsChannel("ShowName") ShowMyStyle=rsChannel("ShowMyStyle") ShowClassTreeGuide=rsChannel("ShowClassTreeGuide") HitsOfHot=rsChannel("HitsOfHot") DaysOfNew=rsChannel("DaysOfNew") MaxPerLine=rsChannel("MaxPerLine") EnableCheck=rsChannel("EnableCheck") DefaultSkinID=rsChannel("DefaultSkinID") ShowAllClass=rsChannel("ShowAllClass") TopMenuType=rsChannel("TopMenuType") ClassGuideType=rsChannel("ClassGuideType") UseCreateHTML=rsChannel("UseCreateHTML") Template_Index=rsChannel("Template_Index") ItemCount_Channel=rsChannel("ItemCount") ItemChecked_Channel=rsChannel("ItemChecked") CommentCount_Channel=rsChannel("CommentCount") SpecialCount_Channel=rsChannel("SpecialCount") HitsCount_Channel=rsChannel("HitsCount") if isNull(ItemCount_Channel) then ItemCount_Channel=0 if isNull(ItemChecked_Channel) then ItemChecked_Channel=0 if isNull(CommentCount_Channel) then CommentCount_Channel=0 if isNull(SpecialCount_Channel) then SpecialCount_Channel=0 if isNull(HitsCount_Channel) then HitsCount_Channel=0 If Trim(ChannelName)<>"" And ShowChannelName=True Then if UseCreateHTML=True then strChannel = strChannel & "" & ChannelName & " | " else strChannel = strChannel & "" & ChannelName & " | " end if end if else if rsChannel("Disabled")<>True And (rsChannel("ShowName")<>False Or rsChannel("ChannelType")=2) then if rsChannel("ChannelType")<=1 then if rsChannel("UseCreateHTML")=True then strChannel=strChannel & "" & rsChannel("ChannelName") & " | " end if end if rsChannel.movenext loop rsChannel.close set rsChannel=nothing If Trim(ChannelName) <> "" And ShowChannelName = True Then if UseCreateHTML=True then strPath=strPath & " >> " & ChannelName & "" else strPath=strPath & " >> " & ChannelName & "" end if strPageTitle=strPageTitle & " >> " & ChannelName end if end sub sub GetChannel_Current() if ChannelID>0 then sqlChannel="select * from PE_Channel where ChannelID=" & ChannelID & " order by OrderID" set rsChannel=server.CreateObject("adodb.recordset") rsChannel.open sqlChannel,conn,1,1 if rsChannel.bof and rsChannel.eof then FoundErr=True ErrMsg=ErrMsg & "系统出现配置错误！请与动力开发团队联系！" else if rsChannel("Disabled")=True then response.write "此频道已经被管理员禁用！" response.end end if ChannelName=rsChannel("ChannelName") ChannelDir=rsChannel("ChannelDir") ChannelShortName=rsChannel("ChannelShortName") ShowChannelName=rsChannel("ShowName") ShowMyStyle=rsChannel("ShowMyStyle") ShowClassTreeGuide=rsChannel("ShowClassTreeGuide") HitsOfHot=rsChannel("HitsOfHot") DaysOfNew=rsChannel("DaysOfNew") MaxPerLine=rsChannel("MaxPerLine") EnableCheck=rsChannel("EnableCheck") DefaultSkinID=rsChannel("DefaultSkinID") ShowAllClass=rsChannel("ShowAllClass") TopMenuType=rsChannel("TopMenuType") ClassGuideType=rsChannel("ClassGuideType") UseCreateHTML=rsChannel("UseCreateHTML") Template_Index=rsChannel("Template_Index") ItemCount_Channel=rsChannel("ItemCount") ItemChecked_Channel=rsChannel("ItemChecked") CommentCount_Channel=rsChannel("CommentCount") SpecialCount_Channel=rsChannel("SpecialCount") HitsCount_Channel=rsChannel("HitsCount") if isNull(ItemCount_Channel) then ItemCount_Channel=0 if isNull(ItemChecked_Channel) then ItemChecked_Channel=0 if isNull(CommentCount_Channel) then CommentCount_Channel=0 if isNull(SpecialCount_Channel) then SpecialCount_Channel=0 if isNull(HitsCount_Channel) then HitsCount_Channel=0 end if end if end sub Function GetSkin_CSS() Dim tSkinID, tempSkinID tSkinID = Trim(request.Cookies("asp163")("SkinID")) If tSkinID = "" Then tSkinID = 0 Else tSkinID = CLng(tSkinID) End If If tSkinID > 0 Then tempSkinID = tSkinID Else tempSkinID = SkinID End If If tempSkinID = 0 Then GetSkin_CSS = "" Else GetSkin_CSS = "" End If End Function '================================================== '函数名：ShowLogo '作 用：显示网站LOGO '参 数：无 '================================================== Function ShowLogo(LogoWidth, LogoHeight) Dim strLogo If LogoUrl <> "" Then strLogo = "" If LCase(Right(LogoUrl, 3)) = "swf" Then If LCase(Left(LogoUrl, 7)) = "http://" Then strLogo = strLogo & "" Else strLogo = strLogo & "" End If Else If LCase(Left(LogoUrl, 7)) = "http://" Then strLogo = strLogo & "" Else strLogo = strLogo & "" End If End If strLogo = strLogo & "" Else strLogo = strLogo & "" End If ShowLogo = strLogo End Function '================================================== '过程名：ShowBanner '作 用：显示网站Banner '参 数：无 '================================================== Function ShowBanner(BannerWidth, BannerHeight) Dim strBanner If BannerUrl <> "" Then If LCase(Right(BannerUrl, 3)) = "swf" Then If LCase(Left(BannerUrl, 7)) = "http://" Then strBanner = "" Else strBanner = "" End If Else If LCase(Left(BannerUrl, 7)) = "http://" Then strBanner = "" Else strBanner = "" End If End If Else strBanner = ShowAD(1) End If ShowBanner = strBanner End Function '================================================== '过程名：ShowAD '作 用：显示广告 '参 数：ADType ---广告类型 '================================================== function ShowAD(ADType) Dim sqlAD, rsAD, strAD, arrSetting, popleft, poptop, floatleft, floattop, fixedleft, fixedtop, ImgUrl If ADType = 0 Then strAD = "" Exit Do ElseIf ADType = 5 Then If InStr(rsAD("ADSetting"), "|") > 0 Then arrSetting = Split(rsAD("ADSetting"), "|") fixedleft = arrSetting(0) fixedtop = arrSetting(1) End If strAD = strAD & "

  没有公告

" strVote = strVote & "    " & rsVote("Title") & "
" If rsVote("VoteType") = "Single" Then For i = 1 To 8 If Trim(rsVote("Select" & i) & "") = "" Then Exit For strVote = strVote & "" & rsVote("Select" & i) & "
" Next Else For i = 1 To 8 If Trim(rsVote("Select" & i) & "") = "" Then Exit For strVote = strVote & "" & rsVote("Select" & i) & "
" Next End If strVote = strVote & "
" strVote = strVote & "" strVote = strVote & "" strVote = strVote & "

" strVote = strVote & "  " strVote = strVote & "" strVote = strVote & "

" ElseIf ShowType = 3 Then strLink = strLink & "友情文字链接站点" End If If ShowType = 1 Or ShowType = 2 Then strLink = strLink & "" End If sqlLink = "select top " & SiteNum & " * from PE_FriendSite where IsOK=1 and LinkType=" & LinkType & " order by IsGood desc,id desc" Set rsLink = Server.CreateObject("adodb.recordset") rsLink.open sqlLink, Conn, 1, 1 If rsLink.bof And rsLink.EOF Then If ShowType = 1 Or ShowType = 2 Then For i = 1 To SiteNum strLink = strLink & "" If i Mod Cols = 0 And i < SiteNum Then strLink = strLink & "" End If Next End If Else i = 1 Do While Not rsLink.EOF If ShowType = 1 Or ShowType = 2 Then If LinkType = 1 Then strLink = strLink & "" Else strLink = strLink & "" End If If i Mod Cols = 0 And i < SiteNum Then strLink = strLink & "" End If Else strLink = strLink & "" & rsLink("SiteName") & "" End If rsLink.movenext i = i + 1 Loop If i < SiteNum And (ShowType = 1 Or ShowType = 2) Then For j = i To SiteNum If LinkType = 1 Then strLink = strLink & "" Else strLink = strLink & "" End If If j Mod Cols = 0 And j < SiteNum Then strLink = strLink & "" End If Next End If End If If ShowType = 1 Or ShowType = 2 Then strLink = strLink & "

" If LinkType = 1 Then strLink = strLink & "" Else strLink = strLink & "点击申请" End If strLink = strLink & "
" If rsLink("LogoUrl") = "" Or rsLink("LogoUrl") = "http://" Then strLink = strLink & "" Else If LCase(Right(rsLink("LogoUrl"), 3)) = "swf" Then strLink = strLink & "" Else strLink = strLink & "" End If End If strLink = strLink & "	" & rsLink("SiteName") & "
	点击申请

" End If If ShowType = 1 Then strLink = strLink & "

" ElseIf ShowType = 3 Then strLink = strLink & "" End If If ShowType = 1 Then strLink = strLink & RollFriendSite() rsLink.Close Set rsLink = Nothing ShowFriendSite = strLink End Function '================================================== '函数名：RollFriendSite '作 用：滚动显示友情链接站点 '参 数：无 '================================================== function RollFriendSite() dim strTemp strTemp="" & vbcrlf RollFriendSite=strTemp end function %> <% Action=trim(request("Action")) if EnableLinkReg=0 then FoundErr=True ErrMsg=ErrMsg & "

管理员没有开放友情链接申请！

" else if Action="Reg" then Call SaveLinkSite() else Call main() end if end if if FoundErr=True then call WriteErrMsg() end if call CloseConn() sub main() %> <% =GetSkin_CSS() %>

本站链接信息 本站名称： <%=SiteName%> 本站地址： <%=SiteUrl%> 本站Logo： 站长姓名： <%=WebmasterName%> 电子邮件： <%=WebmasterEmail%> 本站简介： 股票证券 申请需知： 欢迎各类网站与我们交换连接，只要贵站内容充实且不含反动、色情、暴力等内容。申请链接请先做好本站的链接，本站看到申请后将立即开通贵站连接。如欲申请首页连接，请看这里 申请友情链接 链接类型： Logo链接     文字链接 网站名称： * 网站地址： * 网站Logo： 大小必须是88*31 站长姓名： * 电子邮件： * 网站密码： * 用于修改信息时用。 确认密码： * 网站简介：

<% end sub sub SaveLinkSite() dim LinkType,LinkSiteName,LinkSiteUrl,LinkLogoUrl,LinkSiteAdmin,LinkEmail,LinkSitePassword,LinkSitePwdConfirm,LinkSiteIntro LinkType=trim(request("LinkType")) LinkSiteName=trim(request("SiteName")) LinkSiteUrl=trim(request("SiteUrl")) LinkLogoUrl=trim(request("LogoUrl")) LinkSiteAdmin=trim(request("SiteAdmin")) LinkEmail=trim(request("Email")) LinkSitePassword=trim(request("SitePassword")) LinkSitePwdConfirm=trim(request("SitePwdConfirm")) LInkSiteIntro=trim(request("SiteIntro")) if LinkType="" then FoundErr=True ErrMsg=ErrMsg & "

链接类型不能为空！

" else LinkType=Cint(LinkType) if LinkType=1 and (LinkLogoUrl="" or LinkLogoUrl="http://") then FoundErr=True ErrMsg=ErrMsg & "

请输入网站LOGO地址！

" end if end if if LinkSiteName="" then FoundErr=True ErrMsg=ErrMsg & "

网站名称不能为空！

" end if if LinkSiteUrl="" then FoundErr=True ErrMsg=ErrMsg & "

网站地址不能为空！

" end if if LinkSiteAdmin="" then FoundErr=True ErrMsg=ErrMsg & "

站长姓名不能为空！

" end if if LinkEmail="" then FoundErr=True ErrMsg=ErrMsg & "

Email不能为空！

" else if IsValidEmail(LinkEmail)=false then errmsg=errmsg & "

Email地址错误!

" founderr=true end if end if if LinkSitePassword="" then FoundErr=True ErrMsg=ErrMsg & "

网站密码不能为空！

" end if if LinkSitePwdConfirm="" then FoundErr=True ErrMsg=ErrMsg & "

确认密码不能为空！

" end if if LinkSitePwdConfirm<>LinkSitePassword then FoundErr=True ErrMsg=ErrMsg & "

网站密码与确认密码不一致！

" end if if LinkSiteIntro="" then FoundErr=True ErrMsg=ErrMsg & "

网站简介不能为空！

" end if If FoundErr = True Then Exit Sub End If dim sqlLink,rsLink sqlLink="select top 1 * from PE_FriendSite where SiteName='" & dvHtmlEncode(LinkSiteName) & "' and SiteUrl='" & dvHtmlEncode(LinkSiteUrl) & "'" set rsLink=Server.CreateObject("Adodb.RecordSet") rsLink.open sqlLink,conn,1,3 if not (rsLink.bof and rsLink.eof) then FoundErr=True ErrMsg=ErrMsg & "

你申请的网站已经存在！请不要重复申请！

" else rsLink.Addnew rsLink("LinkType")=LinkType rsLink("SiteName")=dvHtmlEncode(LinkSiteName) rsLink("SiteUrl")=dvHtmlEncode(LinkSiteUrl) rsLink("LogoUrl")=dvHtmlEncode(LinkLogoUrl) rsLink("SiteAdmin")=dvHtmlEncode(LinkSiteAdmin) rsLink("Email")=dvHtmlEncode(LinkEmail) rsLink("SitePassword")=md5(LinkSitePassword) rsLink("SiteIntro")=dvHtmlEncode(LinkSiteIntro) rsLink.update rsLink.close set rsLink=nothing Call WriteSuccessMsg("申请友情链接成功！请等待管理员审核通过。") end if end sub %>en If LCase(Left(LogoUrl, 7)) = "http://" Or Left(LogoUrl, 1) = "/" Then strLogoUrl = LogoUrl Else strLogoUrl = strInstallDir & LogoUrl End If If LCase(Right(strLogoUrl, 3)) = "swf" Then strLogo = "" Else strLogo = "" strLogo = strLogo & " 0 Then strLogo = strLogo & " width='" & LogoWidth & "'" If LogoHeight > 0 Then strLogo = strLogo & " height='" & LogoHeight & "'" strLogo = strLogo & " border='0'>" strLogo = strLogo & "" End If End If GetLogo = strLogo End Function Function GetFsKind_Option(iKindType, KindID) Dim sqlFsKind, rsFsKind, strOption strOption = "不属于任何类别" ElseIf iKindType = 2 Then strOption = strOption & ">不属于任何专题" End If sqlFsKind = "select * from PE_FsKind" If iKindType > 0 Then sqlFsKind = sqlFsKind & " where KindType=" & iKindType End If sqlFsKind = sqlFsKind & " order by KindID" Set rsFsKind = Conn.Execute(sqlFsKind) Do While Not rsFsKind.EOF If rsFsKind("KindID") = KindID Then strOption = strOption & "" & rsFsKind("KindName") & "" Else strOption = strOption & "" & rsFsKind("KindName") & "" End If rsFsKind.movenext Loop rsFsKind.Close Set rsFsKind = Nothing GetFsKind_Option = strOption End Function Function ReplaceUrlBadChar(strChar) If strChar = "" Or IsNull(strChar) Then ReplaceUrlBadChar = "" Exit Function End If Dim strBadChar, arrBadChar, tempChar, i strBadChar = "',(,),<,>,[,],{,},\,;," & Chr(34) & "," & Chr(0) & "" arrBadChar = Split(strBadChar, ",") tempChar = strChar For i = 0 To UBound(arrBadChar) tempChar = Replace(tempChar, arrBadChar(i), "") Next ReplaceUrlBadChar = tempChar End Function Function PE_HTMLEncode(ByVal fString) If IsNull(fString) Or Trim(fString) = "" Then PE_HTMLEncode = "" Exit Function End If fString = Replace(fString, ">", ">") fString = Replace(fString, "<", "<") fString = Replace(fString, Chr(32), " ") fString = Replace(fString, Chr(9), " ") fString = Replace(fString, Chr(34), """) fString = Replace(fString, Chr(39), "'") fString = Replace(fString, Chr(13), "") fString = Replace(fString, Chr(10) & Chr(10), "

") fString = Replace(fString, Chr(10), "
") PE_HTMLEncode = fString End Function %>