convertion de liens

[jemmy1989]

bonjour

j'ai une fonction qui convertie les liens des sites vers la page d'aceuil, exemple

http://www.excel-downloads.com/forum/newthread.php?do=newthread&f=7

devient

http://www.excel-downloads.com

Function FunctionURL(URL)
Dim Char As Variant
Dim Var As Integer
For i = 1 To Len(URL)
Char = Mid(URL, i, 1)
If Char = "/" Then
   Var = Var + 1
End If
If Var = 3 Then
FunctionURL = Left(URL, i - 1)
If FunctionURL = "" Then
FunctionURL = URL
Exit Function
End If
Exit Function
End If
Next i
FunctionURL = FunctionURL
End Function

mais certains sites sont de cette forme

http://forum.site.com/xxxx/xxxx/

ma macro la rend comme ça
http://forum.site.com

je voudrai la modifier pour qu'elle ne garde que ce qu'il y aprés le premier point

c'est à dire que
http://forum.site.com/xxxx/xxxx/

devient
site.com

 

[Papou-net]

Re : convertion de liens

Bonjour jemmy1989,

Essaie comme ceci:

Function FunctionURL(URL)
Dim Char As Variant
Dim Var As Integer
For i = 1 To Len(URL)
  Char = Mid(URL, i, 1)
  If Char = "/" Then
    Var = Var + 1
  End If
  If Var = 3 Then
    FunctionURL = Left(URL, i - 1)
    If FunctionURL = "" Then
      FunctionURL = URL
      Exit Function
    End If
    Exit Function
  End If
Next i
FunctionURL = Mid(FunctionURL, InStr(FunctionURL, ".") + 1)
End Function

NB: j'ai agrémenté ton code avec des tabulations pour mieux comprendre sa structure (une bonne habitude à prendre AMHA).

Cordialement.

 

[jemmy1989]

Re : convertion de liens

salut papounet
merci pour ton code mais ça ne change rien au résultat

http://forum.site.com/xxxx/xxxx/
devient
http://forum.site.com et non site.com

 

[Papou-net]

Re : convertion de liens

RE:

Désolé, mais ce n'est pas toujours évident de modifier un extrait de code sans en connaître le contexte.

Si tu peux joindre un fichier, sans données confidentielles, n'hésite pas.

Cordialement.

 

[david84]

Re : convertion de liens

Bonjour, Salut Papou,
à tester :

Function FunctionURL(URL)
Dim pt&, slash&, c$
pt = InStr(1, URL, ".") + 1
c = Mid(URL, pt, Len(URL) - Len(pt))
slash = InStr(1, c, "/") - 1
FunctionURL = Left(c, slash)
End Function

A+

 

[jemmy1989]

Re : convertion de liens

RE:

Désolé, mais ce n'est pas toujours évident de modifier un extrait de code sans en connaître le contexte.

Si tu peux joindre un fichier, sans données confidentielles, n'hésite pas.

Cordialement.

si je joint un fichier je ne sais pas ce que je pourrais y mettre de plus, que ce que vous n'avez pas compris ?

Bonjour, Salut Papou,
à tester :

Function FunctionURL(URL)
Dim pt&, slash&, c$
pt = InStr(1, URL, ".") + 1
c = Mid(URL, pt, Len(URL) - Len(pt))
slash = InStr(1, c, "/") - 1
FunctionURL = Left(c, slash)
End Function

A+

salut david, ton code fonctionne a 80%, le seul probléme qui reste c'est que certains sites sans point aprés les slash, exemple
https://wikipedia.org/ deviennent org et non wikipedia.org

 

[david84]

Re : convertion de liens

Oui mais ça je ne peux pas le deviner donc sans petit fichier exemple exposant les différents cas à traiter je ne pousse pas plus avant.
A+

 

[jemmy1989]

Re : convertion de liens

voici le fichier

 

[david84]

Re : convertion de liens

Bonsoir,

tu me fournis généreusement 3 adresses...espérons pour toi que cela soit suffisant pour exposer ta demande de manière exhaustive.
A tester (fonction utilisant une expression rationnelle) :

Function ExtraireURL(URL) As String
Dim oRegExp As Object, oMatches As Object
Set oRegExp = CreateObject("vbscript.regexp")

With oRegExp
  .Pattern = "^http(?:s)*://(?:www.)*(\w+[\.-]{1}\w+\.(?:com|net)).*$"
  If .test(URL) = True Then
    Set oMatches = .Execute(URL)
   ExtraireURL = oMatches.Item(0).submatches.Item(0)
  End If
End With

End Function

A+

 

[R@chid]

Re : convertion de liens

Bonjour @ tous,
une solution par formule
Dans le gestionnaire de noms :
MonSite :

=STXT(Feuil1!$A3;TROUVE("/";Feuil1!$A3)+2;TROUVE("$";SUBSTITUE(Feuil1!$A3;"/";"$";3))-TROUVE("/";Feuil1!$A3)-2)

en J3 :

=STXT(MonSite;TROUVE("|";SUBSTITUE("."&MonSite;".";"|";NBCAR(MonSite)-NBCAR(SUBSTITUE(MonSite;".";))));99)

@ tirer vers le bas

Voir PJ

@ + +

 

[david84]

Re : convertion de liens

Bonjour,
le motif peut être simplifié :

Function ExtraireURL(URL) As String
Dim oRegExp As Object, oMatches As Object
Set oRegExp = CreateObject("vbscript.regexp")

With oRegExp
  .Pattern = "//(?:www.)*([^/]+)/"
  If .test(URL) = True Then
    Set oMatches = .Execute(URL)
    ExtraireURL = oMatches.Item(0).submatches.Item(0)
  End If
End With

End Function

A+