<%@language=vbscript codepage=936 %> <% Option Explicit Response.Buffer = True %> <% Dim EnableLinkReg Action = Trim(request("Action")) EnableLinkReg = Conn.Execute("select EnableLinkReg from PE_Config")(0) If EnableLinkReg <> True 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(ErrMsg, ComeUrl) End If Call CloseConn Sub main() %> 申请友情链接
    本站链接信息
    本站名称: <%=SiteName%>
    本站地址: <%=SiteUrl%>
    本站Logo: <%= GetLogo(88, 31) %>
    站长姓名: <%=WebmasterName%>
    电子邮件: <%=WebmasterEmail%>
    本站简介: 请申请链接的同时做好本站的链接。

    申请友情链接
    所属类别:
    所属专题:
    网站名称: *
    网站地址: *
    网站Logo:
    站长姓名: *
    电子邮件:
    网站密码: * 用于修改信息时用。
    确认密码: *
    网站简介:

    <% End Sub Sub SaveLinkSite() Dim KindID, SpecialID, LinkType, LinkSiteName, LinkSiteUrl, LinkLogoUrl, LinkSiteAdmin, LinkSiteEmail, LinkSitePassword, LinkSitePwdConfirm, LinkSiteIntro KindID = PE_CLng(Trim(request.Form("KindID"))) SpecialID = PE_CLng(Trim(request.Form("SpecialID"))) LinkSiteName = Trim(request("SiteName")) LinkSiteUrl = Trim(request("SiteUrl")) LinkLogoUrl = Trim(request("LogoUrl")) LinkSiteAdmin = Trim(request("SiteAdmin")) LinkSiteEmail = Trim(request("SiteEmail")) LinkSitePassword = Trim(request("SitePassword")) LinkSitePwdConfirm = Trim(request("SitePwdConfirm")) LinkSiteIntro = Trim(request("SiteIntro")) If LinkSiteName = "" Then FoundErr = True ErrMsg = ErrMsg & "
  • 网站名称不能为空!
  • " End If If LinkSiteUrl = "" Or LinkSiteUrl = "http://" Then FoundErr = True ErrMsg = ErrMsg & "
  • 网站地址不能为空!
  • " End If If LinkSiteAdmin = "" Then FoundErr = True ErrMsg = ErrMsg & "
  • 站长姓名不能为空!
  • " End If If LinkSiteEmail <> "" And IsValidEmail(LinkSiteEmail) = False Then FoundErr = True ErrMsg = ErrMsg & "
  • 电子邮件地址错误!
  • " 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 If LinkLogoUrl = "" Or LinkLogoUrl = "http://" Then LinkType = 2 Else LinkType = 1 End If Dim sqlLink, rsLink LinkSiteName = ReplaceBadChar(LinkSiteName) LinkSiteUrl = ReplaceUrlBadChar(LinkSiteUrl) sqlLink = "select top 1 * from PE_FriendSite where SiteName='" & LinkSiteName & "' and SiteUrl='" & 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("KindID") = KindID rsLink("SpecialID") = SpecialID rsLink("LinkType") = LinkType rsLink("SiteName") = LinkSiteName rsLink("SiteUrl") = LinkSiteUrl rsLink("LogoUrl") = ReplaceUrlBadChar(LinkLogoUrl) rsLink("SiteAdmin") = PE_HTMLEncode(LinkSiteAdmin) rsLink("SiteEmail") = PE_HTMLEncode(LinkSiteEmail) rsLink("SitePassword") = md5(LinkSitePassword, 16) rsLink("SiteIntro") = PE_HTMLEncode(LinkSiteIntro) rsLink("Hits") = 0 rsLink("UpdateTime") = Now rsLink("Passed") = False rsLink.Update Call WriteSuccessMsg("申请友情链接成功!请等待管理员审核通过。", ComeUrl) End If rsLink.Close Set rsLink = Nothing End Sub Function GetLogo(LogoWidth, LogoHeight) Dim strLogo, strLogoUrl If LogoUrl <> "" Then 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 = " 0 Then strLogo = strLogo & " width='" & LogoWidth & "'" If LogoHeight > 0 Then strLogo = strLogo & " height='" & LogoHeight & "'" strLogo = strLogo & ">" strLogo = strLogo & "" strLogo = strLogo & "" strLogo = strLogo & " 0 Then strLogo = strLogo & " width='" & LogoWidth & "'" If LogoHeight > 0 Then strLogo = strLogo & " height='" & LogoHeight & "'" strLogo = strLogo & " src='" & strLogoUrl & "'" strLogo = strLogo & " wmode='transparent'" strLogo = strLogo & " quality='autohigh'" strLogo = strLogo & "pluginspage='http://www.macromedia.com/shockwave/download/index.cgi?P1_Prod_Version=ShockwaveFlash' type='application/x-shockwave-flash'>" strLogo = 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 & "" Else strOption = strOption & "" 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 tempChar = Replace(tempChar, "@@", "@") 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 %>