Tilføje hjemmeside-link i gæstebog

Jeg har en gæstebog hvor man kan skrive sit navn og sin mail - men ikke en www.adresse.dk og det ku jeg godt tænke mig :)

Så hvis der er én der lige ved hvordan man kringer dén, så blir jeg glad.

Min guestbook.asp:

<%
Function addLinks(sInput, sTarget)
    Dim sNew, sPunct
   
    ' Define punctuation characters
    sPunct = "_-+=!?.,;:`~'""*^$%()[]{}<>|"
   
    ' Assign input string to local variable so we don't change the
    ' original string.
    sNew = sInput

    ' Split the string by whitespace: spaces, carriage returns, line feeds,
    ' and tabs.  Then, for each "word" in the string...
    For Each sVal1 in Split(sNew, " ")
    For Each sVal2 in Split(sVal1, vbcr)
    For Each sVal3 in Split(sVal2, vblf)
    For Each sVal4 in Split(sVal3, Chr(9))
        ' Remove beginning and ending punctuation
        bStop = FALSE
        Do While (Not bStop)
            If (Instr(sPunct, Left(sVal4, 1)) <> 0 And Len(sVal4) > 2) Then
                sVal4 = Mid(sVal4, 2)
            Else
                bStop = TRUE
            End If
        Loop
       
        bStop = FALSE
        Do While (Not bStop)
            If (Instr(sPunct, Right(sVal4, 1)) <> 0 And Len(sVal4) > 2) Then
                sVal4 = Left(sVal4, Len(sVal4) - 1)
            Else
                bStop = TRUE
            End If
        Loop

        ' If the word begins with http:// then convert all occurrences
        ' of this word to a hyperlink.
        If (LCase(Left(sVal4, 7) = "http://") Or LCase(Left(sVal4, 4) = "www.")) Then
            If (LCase(Left(sVal4, 4) = "www.")) Then
                If (sTarget = "") then
                    sNew = Replace(sNew, sVal4, "<A HREF='http://" & sVal4 & "'>" & sVal4 & "</A>")
                Else
                    sNew = Replace(sNew, sVal4, "<A HREF='http://" & sVal4 & "' TARGET=""" & sTarget & """>" & sVal4 & "</A>")
                End If
            Else
                If (sTarget = "") then
                    sNew = Replace(sNew, sVal4, "<A HREF='" & sVal4 & "'>" & sVal4 & "</A>")
                Else
                    sNew = Replace(sNew, sVal4, "<A HREF='" & sVal4 & "' TARGET=""" & sTarget & """>" & sVal4 & "</A>")
                End If
            End If
        End If
       
        ' If this word looks like an e-mail address then convert all
        ' occurrences into a mailto: link.
        If (Instr(sVal4, "@") >= 2 And Instr(sVal4, ".") <> 0 And Len(sVal4) >= 5) Then
            sNew = Replace(sNew, sVal4, "<A HREF=""mailto:" & sVal4 & """>" & sVal4 & "</A>")
        End If
    Next
    Next
    Next
    Next
   
    ' Return converted string
    addLinks = sNew
End Function

ConnectString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Server.MapPath("guestbook.mdb")
Set conn = Server.CreateObject("ADODB.Connection")
conn.open ConnectString

sql = "SELECT * FROM guestbook ORDER BY datetime DESC"
Set rsEntries = Server.CreateObject("ADODB.Recordset")
rsEntries.Open sql, conn, 3, 3
%>

<html>
<head>
<title>..:: O : L : A : K ::..</title>


<SCRIPT src="../images/menu/js.js" type=text/javascript></SCRIPT>
    <LINK href="../images/menu/epictime_tagwall.css" type=text/css rel=stylesheet>
   
</head>
<body link="#FFFFFF" vlink="#FFFFFF" alink="#FFFFFF" id="body">

</body>
<br><br>
<div align="center"><table class="seksten">
<tr>
    <td></td>
    <td></td>
    <td><p><div align="center"><img src="../images/tagwall_sort.jpg" alt="" width="79" height="12" border="0"><br><br><a onmouseover="window.status='Tilføj en besked'; return true"onMouseOut="window.status=''" href="tilfoj.asp">Tilføj besked</a></div></p>
<hr class="borderstagwall">



<a name="messagetop"></a>

<%if rsEntries.EOF then%>


<p align="left">Du kan blive den første til at lægge en besked!</p>
<p>


<%else
rsEntries.Movefirst

'If viewing a previous set of messages, move to the right position
if Request.QueryString("recordnum") <> "" then
  rsEntries.Move(Request.QueryString("recordnum"))
end if

for count = 1 to 15%>

<b>Skrevet af:</b> <%=rsEntries("by")%><br>
<b>Skrevet den:</b> <%=rsEntries("datetime")%><br>
<br>
<b>Besked:</b><br><br>
<%= addLinks(rsEntries("message"),"_blank")%>

</font>


<hr class="borderstagwall">

<%rsEntries.Movenext
'Quit loop if no more messages left
if rsEntries.EOF then
  exit for
end if
next

'If there's still some more messages after displaying the first 20, display a link to the next page, using the .AbsolutePosition property as a placeholder (an ID field in the database is not reliable enough if manual DB deletions occur)

'We use .AbsolutePostion - 1 because we've already done a .Movenext onto the record we want to display first on the next page

if not rsEntries.EOF then%>

</font>
<p><b>
<a onmouseover="window.status='Gamle beskeder'; return true"onMouseOut="window.status=''" href="guestbook.asp?recordnum=<%=rsEntries.AbsolutePosition - 1%>">

Forrige beskeder
</a></b></p>


<%end if%>

<%end if%>

</center>
</font></td>
<td></td>
</tr>
</table></div>


</html>

<%
rsEntries.close
set rsEntries = nothing
conn.close
set conn = nothing
%>


Min guestbook_postprocess.asp:

<%
Option Explicit
Dim ConnectString, sql, conn, rsEntry, by, email, hjemmeside, message

'Assign form values to variables
by = Request.Form("by")
email = Request.Form("email")
hjemmeside = Request.Form("hjemmeside")
message = Request.Form("message")

'If no message entered, kill 'em
if message = "" then
  posterror()
end if

'If invalid email or no email then set it to nothing
if IsEmail(email) = False then
  email = ""
end if

'Open connection and insert user details into the database
ConnectString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Server.MapPath("guestbook.mdb")
Set conn = Server.CreateObject("ADODB.Connection")
conn.open ConnectString

Set rsEntry = Server.CreateObject("ADODB.Recordset")
rsEntry.open "guestbook", conn, 1, 3
rsEntry.AddNew
rsEntry("by") = FormatText(by)
rsEntry("email") = FormatText(email)
rsEntry("hjemmeside") = FormatText(hjemmeside)
rsEntry("message") = FormatText(message)
rsEntry.Update

rsEntry.close
set rsEntry = nothing
conn.close
set conn = nothing

Response.Redirect("guestbook.asp#messagetop")
%>

<%Function posterror()%>
<html>
<head>
<title>Gæstebog - Rune Hansen.tk</title>
<LINK href="../styles.css" type=text/css rel=stylesheet>
</head>
<body background="../Indexbilleder/runehansen.0catch.jpg">
<p><font color="#FFFFFF"><b><a href="guestbook.asp"><font face="Verdana" size="1">Tagwall</font></a> <font face="Verdana" size="1"> - <a href="tilfoj.asp">Tilføj
Besked</a> - <a href="guestbook-admin.asp">Admin Login</a></font></b>
<font face="Verdana" size="1">
<br>
<br>
Du har jo ikke skrevet nogen besked
:|</font></font></p>

<p><a href="java script:self.history.go(-1)"><font face="Verdana" size="1" color="#FFFFFF">Prøv
igen her</font></a></p>
</body>
</html>
<%Response.end
End Function%>

<%'New combined function that strips HTML, adds line breaks, and cuts up words longer than 30 chars
Function FormatText(sIn)
    Dim nCharPos, sOut, bInTag, sChar, wordLen
    sOut = ""
    bInTag = False
    wordLen = 0
    For nCharPos = 1 To Len(sIn)
        sChar = Mid(sIn, nCharPos, 1)
        If sChar = "<" Then
            bInTag = True
        End If
        If Not bInTag Then sOut = sOut & sChar
        If sChar = ">" Then
            bInTag = False
        End If
        if sChar = chr(13) then
            sOut = sOut + "<br>"
        end if
        if sChar = " " then
            wordLen = 0
        else
            wordLen = wordLen + 1
        end if
        if wordLen > 30 then
            sOut = sOut + " "
            wordLen = 0
        end if
    Next
    FormatText = sOut
End Function

Function IsEmail(sCheckEmail)
    Dim sEmail, nAtLoc
    IsEmail = True
    sEmail = Trim(sCheckEmail)
    nAtLoc = InStr(1, sEmail, "@") 'Location of "@"
   
    If Not (nAtLoc > 1 And (InStrRev(sEmail, ".") > nAtLoc + 1)) Then
        '"@" must exist, and last "." in string must follow the "@"
        IsEmail = False
    ElseIf InStr(nAtLoc + 1, sEmail, "@") > nAtLoc Then
        'String can't have more than one "@"
        IsEmail = False
    ElseIf Mid(sEmail, nAtLoc + 1, 1) = "." Then
        'String can't have "." immediately following "@"
        IsEmail = False
    ElseIf InStr(1, Right(sEmail, 2), ".") > 0 Then
        'String must have at least a two-character top-level domain.
        IsEmail = False
    End If
End Function
%>