<%@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()
%>
申请友情链接
<%
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 = ""
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
%>