Category you selected is full, please select another category.
"
end if
end if
'NEW CATEGORY
if SuggestedCategory <> "" then
IF SiteCategory <> "0" then
errorArray(7) = True
ErrorMsg = ErrorMsg & "
You have selected a listed category as well as suggested a new category.
"
end if
end if
'Comments
if Len(Comments) > 200 then
errorArray(8) = True
ErrorMsg = ErrorMsg & "
Comments (200 characters only)
"
end if
end if 'request.form("isSubmitted") = "yes"
%>
<%
If Request.Form("isSubmitted") = "yes" then
DIM all,i
all=False
For i=0 to 9
all=all OR CBOOL(errorArray(i))
Next
If Not all Then
'---------------------------------------------------------------
' CHECK IF LINK ALREADY ADDED - PREVENTS DUPLICATE LINKS
'---------------------------------------------------------------
Set rsCheckReci = Server.CreateObject("ADODB.Recordset")
rsCheckReci.ActiveConnection = strJETconn
rsCheckReci.Source = "SELECT URLReciprocal FROM LinkExchange WHERE URLReciprocal = '" + Replace(URLReciprocal, "'", "''") & "' "
rsCheckReci.CursorType = 0
rsCheckReci.CursorLocation = 2
rsCheckReci.LockType = 1
rsCheckReci.Open()
If rsCheckReci.EOF And rsCheckReci.BOF Then
LinkNotAlreadyAdded = "OK"
Else
errorArray(9) = True
ErrorMsg = ErrorMsg & "
Reciprocal link already exists in our database. To edit your details please contact us
"
End If
rsCheckReci.Close()
Set rsCheckReci = Nothing
End If ' If Not all Then
If LinkNotAlreadyAdded ="OK" Then ' ITS A NEW LINK NO DUPLICATE FOUND
'--------------------------------------------
' INSERT LINK INTO DB
'--------------------------------------------
EmailAddress = Replace(EmailAddress, "'", "''")
FullName = Replace(FullName, "'", "''")
URLTo = Replace(URLTo, "'", "''")
URLReciprocal = Replace(URLReciprocal, "'", "''")
SiteTitle = Replace(SiteTitle, "'", "''")
SiteDescription = Replace(SiteDescription, "'", "''")
SiteCategory = Replace(SiteCategory, "'", "''")
SuggestedCategory = Replace(SuggestedCategory , "'", "''")
Comments = Replace(Comments, "'", "''")
'-----------------------------------------------------
' SET DATE
'-----------------------------------------------------
Dim datetime,Date_Now
datetime = Now()
Date_Now = ReverseFormatDate(datetime)
Date_Now = Replace(Date_Now, "'", "''")
Set cAddLink = Server.CreateObject("ADODB.Connection")
cAddLink.Open strJETconn
varInsertCommand = "INSERT INTO LinkExchange (EmailAddress, FullName, URLTo, URLReciprocal, SiteTitle, SiteDescription, SiteCategory, SuggestedCategory, Comments, DateAdded) VALUES('" & EmailAddress & "', '" & FullName& "', '" & URLTo & "', '" & URLReciprocal & "', '" & SiteTitle & "', '" & SiteDescription & "', '" & SiteCategory & "', '" & SuggestedCategory & "', '" & Comments & "', '" & Date_Now & "');"
cAddLink.Execute(varInsertCommand)
'Response.Write(varInsertCommand)
Set rsGetNewID = cAddLink.Execute("SELECT @@IDENTITY")
NewLinkExchangeID = rsGetNewID(0) ' STORE NEW VARIABLE
rsGetNewID.Close
Set rsGetNewID = Nothing
AddedtoDB = "yes"
'-----------------------------------------------------
' GET FILE NAME FROM CATEGORIES TABLE
'-----------------------------------------------------
If SiteCategory <> "" Then
Set rsLE = Server.CreateObject("ADODB.Recordset")
rsLE.ActiveConnection = strJETconn
rsLE.Source = "SELECT * FROM Categories WHERE CID = " + SiteCategory
rsLE.CursorType = 0
rsLE.CursorLocation = 2
rsLE.LockType = 1
rsLE.Open()
If NOT rsLE.EOF OR NOT rsLE.BOF Then
FileName = rsLE("FileName")
End If
rsLE.Close()
Set rsLE = Nothing
End If
'----------------------------------------------------------------
' CHECK RECIPROCAL LINK ON PARTNERS PAGE
'----------------------------------------------------------------
RecURLStatus = "0"
AutoApproveLink = "0"
FilterWordsStatus = "0"
R_URL = Trim(URLReciprocal)
URLTo = Trim(URLTo)
LinkBackURL = LCASE(Application(COMPANYNAME & "WebsiteURL")) 'OUR SITE LINK
If R_URL <> "" Then
'CHECK THE URL AND ADD HTTP:// IF NOT ADDED ALREADY
If Left(LCase(R_URL),7) <> "http://" Then
R_URL = "http://" & R_URL
End If
End If
If Application(COMPANYNAME & "LinkChecker") = "on" Then
If NewLinkExchangeID <> "" Then
If R_URL <> "" Then
On Error Resume Next
'Create an instance of the XMLHTTP object
Set objXMLHTTP = Server.CreateObject ("Microsoft.XMLHTTP")
objXMLHTTP.open "GET", R_URL, False
objXMLHTTP.send
sHTML=objXMLHTTP.statusText
If Err.number = 0 OR sHTML = "OK" Then
R_URL_Text = objXMLHTTP.ResponseText
R_URL_Text = LCASE(R_URL_Text)
'Check if sLinkBackURL is in the text string returned
If InStr(1,R_URL_Text, LinkBackURL) > 0 Then
RecURLStatus = "1" ' FOUND
Else
RecURLStatus = "2" ' NOT FOUND
End If
Else
RecURLStatus = "3" ' ERROR ACCESING PAGE
End If
objXMLHTTP.close
Set objXMLHTTP = Nothing
Else
RecURLStatus = "2"
End If
'----------------------------------------------
' CHECK BANNED WORDS
'----------------------------------------------
If URLTo <> "" Then
On Error Resume Next
'Create an instance of the XMLHTTP object
Set objXMLHTTP = Server.CreateObject ("Microsoft.XMLHTTP")
objXMLHTTP.open "GET", URLTo, False
objXMLHTTP.send
sHTML=objXMLHTTP.statusText
If Err.number = 0 OR sHTML = "OK" Then
R_URL_Text = objXMLHTTP.ResponseText
R_URL_Text = LCASE(R_URL_Text)
'----------------------------------------
' BANNED WORDS
'----------------------------------------
If Application(COMPANYNAME & "FilterWords") = "on" Then
If FilterWords(R_URL_Text) = 1 Then
FilterWordsStatus = "1"
End If
End If
End If
objXMLHTTP.close
Set objXMLHTTP = Nothing
End If
'--------------------------------------------------------------
' GET LINK FOUND / NOT FOUND EMAIL TEXT
'--------------------------------------------------------------
If RecURLStatus = "1" Then ' Link Found
EmailSQL = "SELECT Config_Name,Config_Value FROM config WHERE Config_Name = 'Link_Checker_Link_Found'"
Else ' Link not found
EmailSQL = "SELECT Config_Name,Config_Value FROM config WHERE Config_Name = 'Link_Checker_Link_Not_Found'"
End If
Dim rsLinkCheckerText
Set rsLinkCheckerText = Server.CreateObject("ADODB.Recordset")
rsLinkCheckerText.ActiveConnection = strJETconn
rsLinkCheckerText.Source = EmailSQL
rsLinkCheckerText.CursorType = 0
rsLinkCheckerText.CursorLocation = 2
rsLinkCheckerText.LockType = 1
rsLinkCheckerText.Open()
' COLLECT VARIABLES
LinkCheckerText = (rsLinkCheckerText.Fields.Item("Config_Value").Value)
rsLinkCheckerText.Close
Set rsLinkCheckerText = Nothing
End If 'NewLinkExchangeID
End If ' link checker - on
'--------------------------------------------------------------
' GET GOOGLE PAGERANK
'--------------------------------------------------------------
If Application(COMPANYNAME & "AutoApproveLink") = "on" Then
If Application(COMPANYNAME & "PRCheckAndApprove") = "on" Then
' URL TO CHECK - RECIPROCAL URL
sURL = R_URL
' GOOGLE PAGERANK CHECKER
Const GOOGLE_MAGIC = &HE6359A60
Function sl(ByVal x, ByVal n)
If n = 0 Then
sl = x
Else
Dim k
k = CLng(2 ^ (32 - n - 1))
Dim d
d = x And (k - 1)
Dim c
c = d * CLng(2 ^ n)
If x And k Then
c = c Or &H80000000
End If
sl = c
End If
End Function
Function sr(ByVal x, ByVal n)
If n = 0 Then
sr = x
Else
Dim y
y = x And &H7FFFFFFF
Dim z
If n = 32 - 1 Then
z = 0
Else
z = y \ CLng(2 ^ n)
End If
If y <> x Then
z = z Or CLng(2 ^ (32 - n - 1))
End If
sr = z
End If
End Function
Function zeroFill(ByVal a, ByVal b)
Dim x
if (&H80000000 AND a) then
x = sr(a,1)
x = x AND (NOT &H80000000)
x = x OR &H40000000
x = sr(x,b-1)
else
x = sr(a,b)
end if
zeroFill = x
End Function
Private Function uadd(ByVal L1, ByVal L2)
Dim L11, L12, L21, L22, L31, L32
L11 = L1 And &HFFFFFF
L12 = (L1 And &H7F000000) \ &H1000000
If L1 < 0 Then L12 = L12 Or &H80
L21 = L2 And &HFFFFFF
L22 = (L2 And &H7F000000) \ &H1000000
If L2 < 0 Then L22 = L22 Or &H80
L32 = L12 + L22
L31 = L11 + L21
If (L31 And &H1000000) Then L32 = L32 + 1
uadd = (L31 And &HFFFFFF) + (L32 And &H7F) * &H1000000
If L32 And &H80 Then uadd = uadd Or &H80000000
End Function
Private Function usub(ByVal L1, ByVal L2)
Dim L11, L12, L21, L22, L31, L32
L11 = L1 And &HFFFFFF
L12 = (L1 And &H7F000000) \ &H1000000
If L1 < 0 Then L12 = L12 Or &H80
L21 = L2 And &HFFFFFF
L22 = (L2 And &H7F000000) \ &H1000000
If L2 < 0 Then L22 = L22 Or &H80
L32 = L12 - L22
L31 = L11 - L21
If L31 < 0 Then
L32 = L32 - 1
L31 = L31 + &H1000000
End If
usub = L31 + (L32 And &H7F) * &H1000000
If L32 And &H80 Then usub = usub Or &H80000000
End Function
Function mix(ByVal ia, ByVal ib, ByVal ic)
Dim a, b, c
a = ia
b = ib
c = ic
a = usub(a,b)
a = usub(a,c)
a = a XOR zeroFill(c,13)
b = usub(b,c)
b = usub(b,a)
b = b XOR sl(a,8)
c = usub(c,a)
c = usub(c,b)
c = c XOR zeroFill(b,13)
a = usub(a,b)
a = usub(a,c)
a = a XOR zeroFill(c,12)
b = usub(b,c)
b = usub(b,a)
b = b XOR sl(a,16)
c = usub(c,a)
c = usub(c,b)
c = c XOR zeroFill(b,5)
a = usub(a,b)
a = usub(a,c)
a = a XOR zeroFill(c,3)
b = usub(b,c)
b = usub(b,a)
b = b XOR sl(a,10)
c = usub(c,a)
c = usub(c,b)
c = c XOR zeroFill(b,15)
Dim ret(3)
ret(0) = a
ret(1) = b
ret(2) = c
mix = ret
End Function
Function gc(ByVal s, ByVal i)
gc = Asc(Mid(s,i+1,1))
End Function
function GoogleCH(ByVal sURL)
Dim iLength, a, b, c, k, iLen, m
iLength = Len(sURL)
a = &H9E3779B9
b = &H9E3779B9
c = GOOGLE_MAGIC
k = 0
iLen = iLength
do while iLen >= 12
a = uadd(a,(uadd(gc(sURL,k+0),uadd(sl(gc(sURL,k+1),8),uadd(sl(gc(sURL,k+2),16),sl(gc(sURL,k+3),24))))))
b = uadd(b,(uadd(gc(sURL,k+4),uadd(sl(gc(sURL,k+5),8),uadd(sl(gc(sURL,k+6),16),sl(gc(sURL,k+7),24))))))
c = uadd(c,(uadd(gc(sURL,k+8),uadd(sl(gc(sURL,k+9),8),uadd(sl(gc(sURL,k+10),16),sl(gc(sURL,k+11),24))))))
m = mix(a,b,c)
a = m(0)
b = m(1)
c = m(2)
k = k + 12
iLen = iLen - 12
loop
c = uadd(c,iLength)
select case iLen ' all the case statements fall through
case 11
c = uadd(c,sl(gc(sURL,k+10),24))
c = uadd(c,sl(gc(sURL,k+9),16))
c = uadd(c,sl(gc(sURL,k+8),8))
b = uadd(b,sl(gc(sURL,k+7),24))
b = uadd(b,sl(gc(sURL,k+6),16))
b = uadd(b,sl(gc(sURL,k+5),8))
b = uadd(b,gc(sURL,k+4))
a = uadd(a,sl(gc(sURL,k+3),24))
a = uadd(a,sl(gc(sURL,k+2),16))
a = uadd(a,sl(gc(sURL,k+1),8))
a = uadd(a,gc(sURL,k+0))
case 10
c = uadd(c,sl(gc(sURL,k+9),16))
c = uadd(c,sl(gc(sURL,k+8),8))
b = uadd(b,sl(gc(sURL,k+7),24))
b = uadd(b,sl(gc(sURL,k+6),16))
b = uadd(b,sl(gc(sURL,k+5),8))
b = uadd(b,gc(sURL,k+4))
a = uadd(a,sl(gc(sURL,k+3),24))
a = uadd(a,sl(gc(sURL,k+2),16))
a = uadd(a,sl(gc(sURL,k+1),8))
a = uadd(a,gc(sURL,k+0))
case 9
c = uadd(c,sl(gc(sURL,k+8),8))
b = uadd(b,sl(gc(sURL,k+7),24))
b = uadd(b,sl(gc(sURL,k+6),16))
b = uadd(b,sl(gc(sURL,k+5),8))
b = uadd(b,gc(sURL,k+4))
a = uadd(a,sl(gc(sURL,k+3),24))
a = uadd(a,sl(gc(sURL,k+2),16))
a = uadd(a,sl(gc(sURL,k+1),8))
a = uadd(a,gc(sURL,k+0))
case 8
b = uadd(b,sl(gc(sURL,k+7),24))
b = uadd(b,sl(gc(sURL,k+6),16))
b = uadd(b,sl(gc(sURL,k+5),8))
b = uadd(b,gc(sURL,k+4))
a = uadd(a,sl(gc(sURL,k+3),24))
a = uadd(a,sl(gc(sURL,k+2),16))
a = uadd(a,sl(gc(sURL,k+1),8))
a = uadd(a,gc(sURL,k+0))
case 7
b = uadd(b,sl(gc(sURL,k+6),16))
b = uadd(b,sl(gc(sURL,k+5),8))
b = uadd(b,gc(sURL,k+4))
a = uadd(a,sl(gc(sURL,k+3),24))
a = uadd(a,sl(gc(sURL,k+2),16))
a = uadd(a,sl(gc(sURL,k+1),8))
a = uadd(a,gc(sURL,k+0))
case 6
b = uadd(b,sl(gc(sURL,k+5),8))
b = uadd(b,gc(sURL,k+4))
a = uadd(a,sl(gc(sURL,k+3),24))
a = uadd(a,sl(gc(sURL,k+2),16))
a = uadd(a,sl(gc(sURL,k+1),8))
a = uadd(a,gc(sURL,k+0))
case 5
b = uadd(b,gc(sURL,k+4))
a = uadd(a,sl(gc(sURL,k+3),24))
a = uadd(a,sl(gc(sURL,k+2),16))
a = uadd(a,sl(gc(sURL,k+1),8))
a = uadd(a,gc(sURL,k+0))
case 4
a = uadd(a,sl(gc(sURL,k+3),24))
a = uadd(a,sl(gc(sURL,k+2),16))
a = uadd(a,sl(gc(sURL,k+1),8))
a = uadd(a,gc(sURL,k+0))
case 3
a = uadd(a,sl(gc(sURL,k+2),16))
a = uadd(a,sl(gc(sURL,k+1),8))
a = uadd(a,gc(sURL,k+0))
case 2
a = uadd(a,sl(gc(sURL,k+1),8))
a = uadd(a,gc(sURL,k+0))
case 1
a = uadd(a,gc(sURL,k+0))
End Select
m = mix(a,b,c)
GoogleCH = m(2)
End Function
Function CalculateChecksum(sURL)
CalculateChecksum = "6" & CStr(ReinterpretSignedAsUnsigned(GoogleCH("info:" & sURL)))
End Function
Function ReinterpretSignedAsUnsigned(ByVal x)
If x < 0 Then x = x + 2 ^ 32
ReinterpretSignedAsUnsigned = x
End Function
theCheck = CalculateChecksum(sURL)
' End Of pagerank sum
'Start get PageRank
Function getPR()
SET objxmlHTTP = CreateObject("Microsoft.XMLHTTP")
Call objxmlHTTP.open("get","http://www.google.com/search?client=navclient-auto&ch="&theCheck& "&q=info:"&sURL, false)
objxmlHTTP.send()
strHTMLText = objxmlHTTP.ResponseText
SET objxmlHTTP = nothing
IF strHTMLText <> "" THEN
varStart = instr(1, strHTMLText,"", vbTextCompare) + 4
IF varStart THEN varStop = instr(varStart,strHTMLText, "", vbTextCompare)
IF varStart AND varStop THEN strIP = mid(strHTMLText, varStart, varStop-varStart)
IF strIP = strIP THEN strip = trim(strIP)
ELSE
StrIP = "PageRank Unavailable"
End If
getPR = strIP
End Function
PageRank = getPR()
'Response.Write(PageRank & " << PageRank ")
End If
End If
'--------------------------------------------------------------
' AUTO APPROVE LINK SETTINGS
'--------------------------------------------------------------
If Application(COMPANYNAME & "AutoApproveLink") = "on" Then
If Application(COMPANYNAME & "LinkChecker") = "on" Then
If SiteCategory <> "0" Then 'CATEGORY AVAILABLE
If RecURLStatus = "1" Then ' LINK ADDED ON RECI. PAGE - CHECKED
'CHEK IF AUTO PR CHECK IS ON
If Application(COMPANYNAME & "PRCheckAndApprove") = "on" Then
If PageRank <> "" Then
If (PageRank * 1) >= (Application(COMPANYNAME & "MinPageRank")) Then
If FilterWordsStatus = 0 Then
AutoApproveLink = "1" ' APPROVE LINK
testing = "A"
End If
Else
AutoApproveLink = "0"
testing = "B"
End If
End If
Else
If Application(COMPANYNAME & "AutoApproveLink") = "on" Then
If FilterWordsStatus = 0 Then
AutoApproveLink = "1"
testing = "C"
End If
Else
AutoApproveLink = "0"
testing = "D"
End If
End If
End If
End If
ELse ' LINK CHECKER IS OFF
If SiteCategory <> "0" Then
If Application(COMPANYNAME & "PRCheckAndApprove") = "on" Then
If PageRank <> "" Then
If (PageRank * 1) >= (Application(COMPANYNAME & "MinPageRank")) Then
If FilterWordsStatus = 0 Then
AutoApproveLink = "1" ' APPROVE LINK
testing = "E"
End If
Else
AutoApproveLink = "0"
testing = "F"
End If
End If
Else
If Application(COMPANYNAME & "AutoApproveLink") = "on" Then
If FilterWordsStatus = 0 Then
AutoApproveLink = "1"
testing = "G"
End If
Else
AutoApproveLink = "0"
testing = "H"
End If
End If
End If
End If
'Response.Write(Application(COMPANYNAME & "MinPageRank") & " << PageRankInDB")
'Response.Write(" " & AutoApproveLink & "<<< AutoApproveLink")
'Response.Write(" " & PageRank & "<<< PageRank")
'Response.Write(" " & Application(COMPANYNAME & "AutoApproveLink") & "<<< autoapprove")
'Response.Write(" " & testing & " <<< testing")
'Response.Write(" " & FilterWordsStatus & " <<< FilterWordsStatus")
'Response.Write(" " & FilterWords(R_URL_Text) & " <<< FilterWords(R_URL_Text)")
'Response.Write(" ")
End If ' AutoApproveLink = on
'----------------------------------------------------------------------
' SEND APPROVED EMAIL IF AUTO APPROVE IS ON AND LINK HAS BEEN ADDED
'----------------------------------------------------------------------
If AutoApproveLink = "1" Then
If Application(COMPANYNAME & "LinkApprovedEmail") = "on" Then
Set rsEmailSettings = Server.CreateObject("ADODB.Recordset")
rsEmailSettings.ActiveConnection = strJETconn
rsEmailSettings.Source = "SELECT * FROM EmailSettings WHERE E_Name = 'LinkApproved'"
rsEmailSettings.CursorType = 0
rsEmailSettings.CursorLocation = 2
rsEmailSettings.LockType = 1
rsEmailSettings.Open()
' COLLECT VARIABLES
EmailMethod = Application(COMPANYNAME & "EmailMethod")
MailServer = Application(COMPANYNAME & "MailServer")
OwnerFromEmail = (rsEmailSettings.Fields.Item("E_FromEmail").Value)
OwnerName = (rsEmailSettings.Fields.Item("E_FromName").Value)
SubjectText = (rsEmailSettings.Fields.Item("E_Subject").Value)
ToAddress = EmailAddress
EmailBody = (rsEmailSettings.Fields.Item("E_Body").Value)
CCAddress = ""
rsEmailSettings.Close
Set rsEmailSettings = Nothing
If Application(COMPANYNAME & "LinkApprovedEmailCopy") = "on" Then
BCCAddress = Application(COMPANYNAME & "LinkApprovedEmailCopyTo")
End If
' RECIPROCAL LINK
LinksDirectoryName = (Replace(LinksDirectory,".",""))
LinksDirectoryName = (Replace(LinksDirectoryName,"/",""))
ReciprocalLink = (Application(COMPANYNAME & "WebsiteURL") + "/" + LinksDirectoryName + "/" + FileName)
' REPLACE VARIABLES
If EmailBody <> "" Then ' REPLACE VARIABLES IN BODY
EmailBody = Replace(EmailBody, "xxxLIDxxx", NewLinkExchangeID)
EmailBody = Replace(EmailBody, "xxxEMAILADDRESSxxx", ToAddress)
EmailBody = Replace(EmailBody, "xxxFULLNAMExxx", FullName)
EmailBody = Replace(EmailBody, "xxxSITELINKxxx", URLTo)
EmailBody = Replace(EmailBody, "xxxSITETITLExxx", SiteTitle)
EmailBody = Replace(EmailBody, "xxxSITECATEGORYxxx", SiteCategory)
If SiteDescription <> "" Then
EmailBody = Replace(EmailBody, "xxxDESCRIPTIONxxx", SiteDescription)
End If
If SuggestedCategory <> "" Then
EmailBody = Replace(EmailBody, "xxxSUGGESTEDCATEGORYxxx", SuggestedCategory)
End If
If Comments <> "" Then
EmailBody = Replace(EmailBody, "xxxCOMMENTSxxx", Comments)
End If
If LinkCheckerText <> "" Then
EmailBody = Replace(EmailBody, "xxxLINKCHECKERTEXTxxx", LinkCheckerText)
Else
EmailBody = Replace(EmailBody, "xxxLINKCHECKERTEXTxxx", "")
End If
EmailBody = Replace(EmailBody, "xxxRECIPROCALLINKxxx", ReciprocalLink)
EmailBody = Replace(EmailBody, "xxxLINKLOCATIONxxx", URLReciprocal)
EmailBody = Replace(EmailBody, "xxxCUSTOMTEXTxxx", Application(COMPANYNAME & "CustomText"))
ELSE
EmailBody = ""
END IF
' EMAIL BODY
EmailBodyText = (EmailBody)
' SEND EMAIL USING FUNCTION
Call SendEMail(EmailMethod, MailServer, ToAddress, CCAddress, BCCAddress, OwnerFromEmail, OwnerName, SubjectText, EmailBodyText, false)
End If 'LinkApprovedEmail = on
Else ' AutoApproveLink = "1"
'--------------------------------------------------------------
' SEND LINK REQUEST EMAIL IF ON AND ALSO IF AUTO APPROVE OFF
'--------------------------------------------------------------
If Application(COMPANYNAME & "LinkRequestReceivedEmail") = "on" Then
Set rsEmailSettings = Server.CreateObject("ADODB.Recordset")
rsEmailSettings.ActiveConnection = strJETconn
rsEmailSettings.Source = "SELECT * FROM EmailSettings WHERE E_Name = 'LinkReceived'"
rsEmailSettings.CursorType = 0
rsEmailSettings.CursorLocation = 2
rsEmailSettings.LockType = 1
rsEmailSettings.Open()
' COLLECT VARIABLES
EmailMethod = Application(COMPANYNAME & "EmailMethod")
MailServer = Application(COMPANYNAME & "MailServer")
OwnerFromEmail = (rsEmailSettings.Fields.Item("E_FromEmail").Value)
OwnerName = (rsEmailSettings.Fields.Item("E_FromName").Value)
SubjectText = (rsEmailSettings.Fields.Item("E_Subject").Value)
ToAddress = EmailAddress
EmailBody = (rsEmailSettings.Fields.Item("E_Body").Value)
CCAddress = ""
If Application(COMPANYNAME & "LinkRequestReceivedEmailCopy") = "on" Then
BCCAddress = Application(COMPANYNAME & "LinkRequestReceivedEmailCopyTo")
End If
rsEmailSettings.Close
Set rsEmailSettings = Nothing
' REPLACE VARIABLES
If EmailBody <> "" Then ' REPLACE VARIABLES IN BODY
EmailBody = Replace(EmailBody, "xxxLIDxxx", NewLinkExchangeID)
EmailBody = Replace(EmailBody, "xxxEMAILADDRESSxxx", ToAddress)
EmailBody = Replace(EmailBody, "xxxFULLNAMExxx", FullName)
EmailBody = Replace(EmailBody, "xxxSITELINKxxx", URLTo)
EmailBody = Replace(EmailBody, "xxxSITETITLExxx", SiteTitle)
EmailBody = Replace(EmailBody, "xxxSITECATEGORYxxx", SiteCategory)
If SiteDescription <> "" Then
EmailBody = Replace(EmailBody, "xxxDESCRIPTIONxxx", SiteDescription)
End If
If SuggestedCategory <> "" Then
EmailBody = Replace(EmailBody, "xxxSUGGESTEDCATEGORYxxx", SuggestedCategory)
End If
If Comments <> "" Then
EmailBody = Replace(EmailBody, "xxxCOMMENTSxxx", Comments)
End If
If LinkCheckerText <> "" Then
EmailBody = Replace(EmailBody, "xxxLINKCHECKERTEXTxxx", LinkCheckerText)
Else
EmailBody = Replace(EmailBody, "xxxLINKCHECKERTEXTxxx", "")
End If
EmailBody = Replace(EmailBody, "xxxLINKLOCATIONxxx", URLReciprocal)
EmailBody = Replace(EmailBody, "xxxCUSTOMTEXTxxx", Application(COMPANYNAME & "CustomText"))
ELSE
EmailBody = ""
END IF
' EMAIL BODY
EmailBodyText = (EmailBody)
' SEND EMAIL USING FUNCTION
Call SendEMail(EmailMethod, MailServer, ToAddress, CCAddress, BCCAddress, OwnerFromEmail, OwnerName, SubjectText, EmailBodyText, false)
End If 'LinkRequestReceivedEmail
End If ' AutoApproveLink = "1"
'-----------------------------------------------------
' UPDATE RecURLStatus
'-----------------------------------------------------
ExecuteSQL("UPDATE LinkExchange SET RecURLStatus = " + RecURLStatus + ", Approved = " + AutoApproveLink + ", AddLinkPage = '" + FileName + "', FilterWordsStatus =" + FilterWordsStatus + " WHERE LEID = " + Replace(NewLinkExchangeID, "'", "''"))
'Response.Write(">>>UPDATE LinkExchange SET RecURLStatus = " + RecURLStatus + ", Approved = " + AutoApproveLink + ", AddLinkPage = '" + FileName + "', FilterWordsStatus =" + FilterWordsStatus + " WHERE LEID = " + Replace(NewLinkExchangeID, "'", "''"))
'-------------------------------------------
' CLEAR VARIABLES
'-------------------------------------------
EmailAddress = ""
FullName = ""
URLTo = ""
URLReciprocal = ""
SiteTitle = ""
SiteDescription = ""
SiteCategory = ""
SuggestedCategory = ""
Comments = ""
End If ' LinkNotAlreadyAdded = "OK" 'PREVENTS DUPLICATE
End If ' isSubmitted
'----------------------------------------
' CATEGORIES
'----------------------------------------
Set rsCats = Server.CreateObject("ADODB.Recordset")
rsCats.ActiveConnection = strJETconn
rsCats.Source = "SELECT * FROM Categories ORDER BY CatOrder ASC"
rsCats.CursorType = 0
rsCats.CursorLocation = 2
rsCats.LockType = 1
rsCats.Open()
'-------------------------------------------------
' CREATE HTML LINK TO BE USED IN
'-------------------------------------------------
Dim HTMLCODE
HTMLCODE = "" & Application(COMPANYNAME & "WebsiteTitle") & " " & Application(COMPANYNAME & "WebsiteDescription")
%>
Add Reciprocal Link
<%
'-----------------------------------------------
' WRITE TEMPLATE PAGE FIRST ARRAY
'-----------------------------------------------
response.write(aTemplatePage(0))
%>
