webForumDet fria alternativet

Skriva ut som länk

ASP

1 svar · 363 visningar · startad av wika

Medlem sedan dec. 200524 inlägg
Frågan#1

Har en drös med funktioner i denna kod, men vill bara ha den som formaterar "http://" till en länk när texten skrivs ut.
Vad ska jag ta bort?

'Formatterar text från databasen 
function checkText(forumText)
	'Radbrytning
	forumText = replace(forumText, chr(13), "<br>")
	forumText = Replace(forumText, "[app]", "'")
	
	'Skapar intendering
	forumText = replace(forumText, chr(32)&chr(32)&chr(32), "&nbsp;&nbsp;&nbsp;")
	
	'Söksträng markeras
	if not request.querystring("search") = "" then
		if not InStr(1, lcase(forumText), request.querystring("search")) = 0 then
			forumText = replace(lcase(forumText), request.querystring("search"), "<span>" & request.querystring("search") & "</span>")
		end if
	end if
	

	'Fet stil
	forumText = replace(forumText, "[b]", "<b>")
	forumText = replace(forumText, "[/b]", "</b>")
	forumText = replace(forumText, "[B]", "<b>")
	forumText = replace(forumText, "[/B]", "</b>")
	
	'Kursiv stil
	forumText = replace(forumText, "[i]", "<i>")
	forumText = replace(forumText, "[/i]", "</i>")
	forumText = replace(forumText, "[I]", "<i>")
	forumText = replace(forumText, "[/I]", "</i>")
	
	'Understruken stil
	forumText = replace(forumText, "[u]", "<u>")
	forumText = replace(forumText, "[/u]", "</u>")
	forumText = replace(forumText, "[U]", "<u>")
	forumText = replace(forumText, "[/U]", "</u>")

	'Centrerad stil
	forumText = replace(forumText, "[c]", "<center>")
	forumText = replace(forumText, "[/c]", "</center>")
	forumText = replace(forumText, "[C]", "<center>")
	forumText = replace(forumText, "[/C]", "</center>")
	
	'Kollar efter länkar
	forumText = checkForLinks(forumText)

	'Kollar efter länkar till polare
	forumText = encode(forumText)
	
	
	checkText = forumText
end function

Function encode(mess)

Set objRegExp = New regexp
objRegExp.Global = true
objRegExp.IgnoreCase = true
mess = mess

objRegExp.Pattern = "\[m](.*?)\[/m\]"
mess = objRegExp.Replace(mess,"<a href=""send.asp?what=touser&username=$1""><b>$1</b></a>")

encode = mess
End Function

Function checkForLinks(strInput)
	dim intStartPos, intStopPos, intPos
	dim strChar, strURL, strShowURL
	dim bolFin
	dim intRoof, k
	dim arrURL
	dim strOrg
	
	strOrg = strInput
	
	intRoof = 100
	bolFin = false
	k = 0
	
	do until bolFin = true or k = intRoof
		if not instr(1, strInput, "http://") = 0 then
			intStartPos = instr(1, strInput, "http://")
			intStopPos = len(strInput) + 1
			
			for i = intStartPos to intStopPos
				if i = intStopPos then
					strChar = mid(strInput, i, 1)
					bolFin = true
					exit for
				else
					strChar = mid(strInput, i, 1)
				end if
				
				strURL = strURL & strChar
				
				select case strChar
					case " ",")","(","[","{","!"
						strURL = left(strURL, len(strURL) - 1) & ","
						if not mid(strInput, i, intStopPos) = strInput then
							strInput = mid(strInput, i, intStopPos)
						else
							bolFin = true
						end if
						exit for
				end select
			next
		else
			bolFin = true
		end if
		
		k = k + 1
	loop
	
	strURL = replace(strURL, "<br>", ",")
	if right(strURL, 1) = "," then
		strURL = left(strURL, len(strURL) - 1)
	end if
	strURL = trim(strURL)
	arrURL = split(strURL, ",")
	
	for i = 0 to ubound(arrURL)
		if asc(arrURL(i)) = 10 then
			arrURL(i) = right(arrURL(i), len(arrURL(i)) - 1)
		elseif right(arrURL(i), 1) = "." then
			arrURL(i) = left(arrURL(i), len(arrURL(i)) - 1)
		end if
		if not arrURL(i) = "" then
			if left(arrURL(i), 7) = "http://" then
				strShowURL = arrURL(i)
				strOrg = replace(strOrg, arrURL(i), "<a href=""" & replace(replace(arrURL(i), "<span>", ""), "</span>", "") & """ target=""_blank""><b>" & replace(strShowURL, "http://", "") & "</b></a>")
			end if
		end if
	next
	
	checkForLinks = strOrg
End Function

'Översätter svenska tecken till kod och tvärtom
function translateChars(tcStr, tcWay)
	select case tcWay
		case 0 'Svenska till kod
			tcStr = replace(tcStr, "å", "&#229;")
			tcStr = replace(tcStr, "Å", "&#197;")
			tcStr = replace(tcStr, "ä", "&#228;")
			tcStr = replace(tcStr, "Ä", "&#196;")
			tcStr = replace(tcStr, "ö", "&#246;")
			tcStr = replace(tcStr, "Ö", "&#214;")
		
		case 1 'Kod till svenska
			tcStr = replace(tcStr, "&#229;", "å")
			tcStr = replace(tcStr, "&#197;", "Å")
			tcStr = replace(tcStr, "&#228;", "ä")
			tcStr = replace(tcStr, "&#196;", "Ä")
			tcStr = replace(tcStr, "&#246;", "ö")
			tcStr = replace(tcStr, "&#214;", "Ö")
	end select
	
	translateChars = tcStr
end function

'Ersätter ej tillåtna tecken
function cleanString(csStr)
	csStr = replace(csStr, "'", "")
	
	cleanString = csStr
end function

response.write checkText(server.HTMLEncode(rs("presentation")))
Medlem sedan dec. 19996 721 inlägg
#2

Det står ju klart och tydligt vad som gör vad. Antingen tar du bort allt utom raden som "Kollar efter länkar", eller ännu hellre, använd funktionen "checkForLinks" direkt, i ställer för "checkText"

462 ms totalt · 4 externa anrop · v20260731065814-full.86ec41c2
321 ms — deklarationer (db)
0 ms — hämta statistik (cache)
135 ms — hämta tråd, inlägg och bilagor (db)
325 ms — ändringar (db)