convertire in link gli url e gli indirizzi email

[Daniele80]

ciao,
qualcuno di voi ha queste funzioni, io devo trovare dentro a del testo cosi formato:

[ center ]ciao [ b ]daniele[ /b ] [ /center ]
domani controlla questi indirizzi:
[list ][* ]http://www.dds.rm.it[/ *][ *]www.dds.rm.it [ /*][ /list]
poi fammi sapere che ne pensi, mandami i tuoi pensieri a questo email : [ email]frascovich@portalis.it[/ email]

i vari url e indirizzi email e trasformarli in link, praticamente come accade in questo forum


grazie

PS. ho scritto cosi di proposito altrimenti sarebbe stato tutto codificato

[Daniele80]

oer chiunque la desideri, l'ho trovata nel forum ASP

' var globali
Dim intInizio As Integer
Dim strProt As String

Sub trovaInizio(ByVal stringa, ByVal inizio)
            Dim intHttp, intWww, intMail, intSpazio, intEnter, intFtp, intNews As Integer

            strProt = "" ' azzera la stringa del protocollo  
            intHttp = InStr(inizio, stringa, "http://")  ' determina posizione http://
            intWww = InStr(inizio, stringa, "www.")   ' determina posizione www.
            intMail = InStr(inizio, stringa, "@")   ' determina posizione chiocciola
            If intMail > 0 Then    ' se c'è una chiocciola
                intSpazio = InStrRev(stringa, " ", intMail) + 1 ' determina posizione spazio prima della chiocciola
                intEnter = InStrRev(stringa, Chr(13), intMail) + 1    'determina posizione ritorno a capo prima della chiocciola
                If intSpazio > intEnter Then ' determina inizio effettivo dell'indirizzo email 
                    intMail = intSpazio
                Else
                    intMail = intEnter
                End If
            End If
            intFtp = InStr(inizio, stringa, "ftp://")   ' determina posizione ftp://
            intNews = InStr(inizio, stringa, "news://")   ' determina posizione news://     
            If intHttp = 0 Or (intWww > 0 And intHttp > intWww) Then    ' determina inizio indirizzo http: se non c'è http è la posizione di www.
                intInizio = intWww
                strProt = "http://"  ' e allora aggiunge il protocollo per costruire il link
            Else    ' altrimenti e' quella di http
                intInizio = intHttp
            End If
            If intMail > 0 And (intInizio = 0 Or intInizio > intMail) Then   ' determina inizio del primo indirizzo nella stringa
                intInizio = intMail  ' mail
                strProt = "mailto:"  ' aggiunge protocollo
            End If
            If intFtp > 0 And (intInizio = 0 Or intInizio > intFtp) Then
                intInizio = intFtp    ' ftp
                strProt = ""      ' azzera protocollo
            End If
            If intNews > 0 And (intInizio = 0 Or intInizio >= intNews) Then
                intInizio = intNews    ' news
                strProt = ""      ' azzera protocollo
            End If
        End Sub

        Function formatUrl(ByVal input As String) As String
            Dim strOutput, strUrl As String
            Dim intFine, cntConta As Integer
            Dim arrCar() As String = {Chr(13), ",", ". ", ": ", ";", "!", "? ", ".."}  ' matrice con i caratteri possibili di fine url, escluso lo spazio di default
            strOutput = input    ' stringa di output. Inizialmente è uguale a quella di input.
            input = input & " "    ' aggiunge alla stringa di input uno spazio per gestire il caso in cui non vi siano altri caratteri dopo l'ultimo url
            trovaInizio(input, 1)   ' trova inizio primo indirizzo
            Do While intInizio > 0  ' ciclo di controllo stringa input. Prosegue fino a che non ci sono più possibili url 
                intFine = InStr(intInizio, input, " ") ' determina posizione spazio dopo l'url
                For cntConta = 0 To UBound(arrCar)  ' determina fine url effettiva controllando la presenza dei caratteri di fine url possibili
                    If InStr(intInizio, input, arrCar(cntConta)) > 0 And intFine > InStr(intInizio, input, arrCar(cntConta)) Then intFine = InStr(intInizio, input, arrCar(cntConta))
                Next
                strUrl = Mid(input, intInizio, intFine - intInizio) ' estrae l'url
                strOutput = Replace(strOutput, strUrl, "" & strUrl & "")     'inserisce il tag <a> nella stringa di output
                trovaInizio(input, intFine) ' trova inizio indirizzi successivi
            Loop
            Return strOutput
        End Function

cosi si fa partire il tutto
Campo = formatUrl(Campo)

[dwb]

Grazie!