XL 2016 Comment récupérer le texte d'un lien hypertext ?

scoubidou35

XLDnaute Occasionnel
Bonjour à tous,
je suis toujours sur mon fichier et je n'arrive pas à trouver de solution malgré mes recherches sur internet et mon livre sur le vba :(

Je voudrais pour gagner du temps a ne pas avoir à saisir le titre du site ou documents pour chaque liens hypertextes. J'ai donc insérer dans le code des lignes pour agir sur les chaines de caractères et ca fonctionne sauf que j'ai fait le test sur un autre fichier avec une adresse copier/coller et non directement sur un lien hypertexte.
Résultat ca fonctionne mais cela me donne une second lien hypertexte et une fois incorporer au code du fichier joints là ca ne fonctionne plus du tout je n'ai plus rien seul la première partie du code fonctionne toujours.

j'espère avoir été clair dans mes explications sinon n'hésitez pas à me poser vos questions.
Merci
 

Pièces jointes

  • LiensHypertext(1) (3).xlsm
    20.1 KB · Affichages: 21
Solution
J'ai trouvé la cause j'ai fait le teste avec un pdf :

Comment récupérer le texte d'un lien hypertext ?

Décodage de chaînes UTF-8 codées url dans VBScript
- https://newbedev.com/decoding-url-encoded-utf-8-strings-in-vbscript

Les codes d'encodage du caractère spécial « % » ou « pour cent ».
- https://outils-javascript.aliasdmc..../encode-caractere-0025-html-css-js-autre.html

VB:
Option Explicit

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)

If Range(Target.Address).Hyperlinks.Count > 0 Then
' Comment récupérer le texte d'un lien hypertext ?
' Colone 1 = Target.Value
' Colonne 2 = Target.Offset(0, 1).Value
    Target.Offset(0, 1).Value =...

scoubidou35

XLDnaute Occasionnel
Bonjour à tous et à toutes,

J'ai avancé sur le sujet, mais le code fonctionne aléatoirement....il me donne presque la chaine de caractères souhaitées mais un coup ca fonctionne et si je retente plus rien et je ne comprends pas pourquoi. Et sinon je ne sais pas comment insérer les codes 'replace' j'ai essayé à la suite du code mais ca ne fonctionne pas et la je sèche complètement donc besoins d'aide.
Merci d'avance
 

Pièces jointes

  • LiensHypertext(1)bis.xlsm
    20.4 KB · Affichages: 11

laurent950

XLDnaute Accro
Bonsoir :
- je ferais cette modification :

VB:
Option Explicit
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
If Range(Target.Address).Hyperlinks.Count > 0 Then
' Comment récupérer le texte d'un lien hypertext ?
' Colone 1 = Target.Value
' Colonne 2 = Target.Offset(0, 1).Value
    Target.Value = Trim(Split(Target.Hyperlinks.Item(1).Address, "\")((UBound(Split(Target.Hyperlinks.Item(1).Address, "\")))))
'Liste pour remmplacer
               Target.Value = Replace(Target.Value, "%20", " ")
               Target.Value = Replace(Target.Value, "é", "é")
               Target.Value = Replace(Target.Value, "ê", "ê")
End If
End Sub
 
Dernière édition:

laurent950

XLDnaute Accro
re,

Remplacer en Rouge par en Vert (Target c'est un Objet)

ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=strLien _
, TextToDisplay:=Chr(158)

Target.Hyperlinks.Add Anchor:=Target, Address:=strLien _
, TextToDisplay:=Chr(158)


VB:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim strLien As String
    If Not Intersect(Target, Range("Tableau1[Liens]")) Is Nothing Then
        With Target
            If .Count = 1 Then
            If .Value = "" Then
                    strLien = Application.InputBox("Entrez le lien hypertexte.", "Insertion lien hypertexte", "Entrez le texte")
                    Select Case strLien
                        Case False
                            MsgBox "Insertion du lien annulée", vbOKOnly + vbInformation, "Intertion de lien"
                        Case "Entrez le texte"
                            ' // Ici ton message

                        Case Else
                            Target.Hyperlinks.Add Anchor:=Target, Address:=strLien _
                                                                                   , TextToDisplay:=Chr(158)
                            .Value = Chr(158)
                            .Font.Name = "Webdings"
                            .Font.Color = vbBlue
                            .Font.Size = 24
                            .Font.Underline = False
                    End Select
                End If
            End If
        End With
    End If
End Sub
 

scoubidou35

XLDnaute Occasionnel
Bonsoir :
- je ferais cette modification :

VB:
Option Explicit
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
If Range(Target.Address).Hyperlinks.Count > 0 Then
' Comment récupérer le texte d'un lien hypertext ?
' Colone 1 = Target.Value
' Colonne 2 = Target.Offset(0, 1).Value
    Target.Offset(0, 1).Value = Trim(Split(Target.Hyperlinks.Item(1).Address, "\")((UBound(Split(Target.Hyperlinks.Item(1).Address, "\")))))
'Liste pour remmplacer
               Target.Value = Replace(Target.Value, "%20", " ")
               Target.Value = Replace(Target.Value, "é", "é")
               Target.Value = Replace(Target.Value, "ê", "ê")
End If
End Sub
Bonsoir Laurent950,
Merci pour votre réponse.
Je viens de faire les modifications dans Private Sub Worksheet_SelectionChange and j'ai bien mon hypertext avec le caractère chr(158) mais par contre je n'ai rien sur la colonne suivante.
 

laurent950

XLDnaute Accro
mais par contre je n'ai rien sur la colonne suivante.
' Colone 1 = Target.Value
' Colonne 2 = Target.Offset(0, 1).Value
VB:
Option Explicit
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
If Range(Target.Address).Hyperlinks.Count > 0 Then
' Comment récupérer le texte d'un lien hypertext ?
' Colone 1 = Target.Value
' Colonne 2 = Target.Offset(0, 1).Value
    Target.Offset(0, 1).Value = Trim(Split(Target.Hyperlinks.Item(1).Address, "\")((UBound(Split(Target.Hyperlinks.Item(1).Address, "\")))))
'Liste pour remmplacer
               Target.Offset(0, 1).Value = Replace(Target.Offset(0, 1).Value, "%20", " ")
               Target.Offset(0, 1).Value = Replace(TTarget.Offset(0, 1).Value, "é", "é")
               Target.Offset(0, 1).Value = Replace(Target.Offset(0, 1).Value, "ê", "ê")
End If
End Sub
 

scoubidou35

XLDnaute Occasionnel
Bonsoir :
- je ferais cette modification :

VB:
Option Explicit
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
If Range(Target.Address).Hyperlinks.Count > 0 Then
' Comment récupérer le texte d'un lien hypertext ?
' Colone 1 = Target.Value
' Colonne 2 = Target.Offset(0, 1).Value
    Target.Offset(0, 1).Value = Trim(Split(Target.Hyperlinks.Item(1).Address, "\")((UBound(Split(Target.Hyperlinks.Item(1).Address, "\")))))
'Liste pour remmplacer
               Target.Value = Replace(Target.Value, "%20", " ")
               Target.Value = Replace(Target.Value, "é", "é")
               Target.Value = Replace(Target.Value, "ê", "ê")
End If
End Sub
Re

J'ai trouvé la cause j'ai fait le teste avec un pdf : file:///E:/Documents/Essai%20de%20la%20Mac%C3%A9ration%20Huileuse%20d'Ail%20sur%20la%20Cloque%20du%20P%C3%AAcher.pdf

mais les é et ê ne donne pas le même résultats avec l'adresse texte de la 2ieme colonne
 

laurent950

XLDnaute Accro
J'ai trouvé la cause j'ai fait le teste avec un pdf :

Comment récupérer le texte d'un lien hypertext ?

Décodage de chaînes UTF-8 codées url dans VBScript
- https://newbedev.com/decoding-url-encoded-utf-8-strings-in-vbscript

Les codes d'encodage du caractère spécial « % » ou « pour cent ».
- https://outils-javascript.aliasdmc..../encode-caractere-0025-html-css-js-autre.html

VB:
Option Explicit

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)

If Range(Target.Address).Hyperlinks.Count > 0 Then
' Comment récupérer le texte d'un lien hypertext ?
' Colone 1 = Target.Value
' Colonne 2 = Target.Offset(0, 1).Value
    Target.Offset(0, 1).Value = Trim(Split(Target.Hyperlinks.Item(1).Address, "\")((UBound(Split(Target.Hyperlinks.Item(1).Address, "\")))))
'Liste pour remmplacer
               Target.Offset(0, 1).Value = Replace(Target.Offset(0, 1).Value, "%20", " ")
               Target.Offset(0, 1).Value = Replace(Target.Offset(0, 1).Value, "é", "é")
               Target.Offset(0, 1).Value = Replace(Target.Offset(0, 1).Value, "ê", "ê")
' REGEX (Fonction de conversion)
                Target.Offset(0, 1).Value = URLDecode(Target.Offset(0, 1).Value)  ' Target.Offset(0, 1).Value = sStr
End If
End Sub
'
'
' Fonction ci-dessous
Function RegExTest(str, patrn)
    Dim regEx As Object
        Set regEx = CreateObject("VBScript.RegExp")
    regEx.IgnoreCase = True
    regEx.Pattern = patrn
    RegExTest = regEx.test(str)
End Function
'
Function URLDecode(sStr)
' https://newbedev.com/decoding-url-encoded-utf-8-strings-in-vbscript
' Décodage de chaînes UTF-8 codées url dans VBScript
    Dim str, code, a0
    str = ""
    code = sStr
    code = Replace(code, "+", " ")
    While Len(code) > 0
        If InStr(code, "%") > 0 Then
            str = str & Mid(code, 1, InStr(code, "%") - 1)
            code = Mid(code, InStr(code, "%"))
            a0 = UCase(Mid(code, 2, 1))
            If a0 = "U" And RegExTest(code, "^%u[0-9A-F]{4}") Then
                str = str & ChrW((Int("&H" & Mid(code, 3, 4))))
                code = Mid(code, 7)
            ElseIf a0 = "E" And RegExTest(code, "^(%[0-9A-F]{2}){3}") Then
                str = str & ChrW((Int("&H" & Mid(code, 2, 2)) And 15) * 4096 + (Int("&H" & Mid(code, 5, 2)) And 63) * 64 + (Int("&H" & Mid(code, 8, 2)) And 63))
                code = Mid(code, 10)
            ElseIf a0 >= "C" And a0 <= "D" And RegExTest(code, "^(%[0-9A-F]{2}){2}") Then
                str = str & ChrW((Int("&H" & Mid(code, 2, 2)) And 3) * 64 + (Int("&H" & Mid(code, 5, 2)) And 63))
                code = Mid(code, 7)
            ElseIf (a0 <= "B" Or a0 = "F") And RegExTest(code, "^%[0-9A-F]{2}") Then
                str = str & Chr(Int("&H" & Mid(code, 2, 2)))
                code = Mid(code, 4)
            Else
                str = str & "%"
                code = Mid(code, 2)
            End If
        Else
            str = str & code
            code = ""
        End If
    Wend
    URLDecode = str
End Function
 
Dernière édition:

laurent950

XLDnaute Accro
Re
Pour Faire des tests avant avec d'autres caractères
Code ci-dessous
Résultat dans la Msgbox
Pris en compte avec la fonction Regex (ci-dessous)
"%20" ----->>> " ")
Normalement cette ligne peux être supprimer (a vérifier)
Target.Offset(0, 1).Value = Replace(Target.Offset(0, 1).Value, "%20", " ")
Non Pris en compte avec la fonction Regex
"é" ----->>> "é"
"ê" ----->>> "ê"
Target.Offset(0, 1).Value = Replace(Target.Offset(0, 1).Value, "é", "é")
Target.Offset(0, 1).Value = Replace(Target.Offset(0, 1).Value, "ê", "ê")

Code:
' La chaine à tester
Sub test()
' Pour faire des Testes
    MsgBox URLDecode("file:///E:/Documents/Essai%20de%20la%20Mac%C3%A9ration%20Huileuse%20d'Ail%20sur%20la%20Cloque%20du%20P%C3%AAcher.pdf")
End Sub
'
Function RegExTest(str, patrn)
    Dim regEx As Object
        Set regEx = CreateObject("VBScript.RegExp")
    regEx.IgnoreCase = True
    regEx.Pattern = patrn
    RegExTest = regEx.test(str)
End Function
'
Function URLDecode(sStr)
    Dim str, code, a0
    str = ""
    code = sStr
    code = Replace(code, "+", " ")
    While Len(code) > 0
        If InStr(code, "%") > 0 Then
            str = str & Mid(code, 1, InStr(code, "%") - 1)
            code = Mid(code, InStr(code, "%"))
            a0 = UCase(Mid(code, 2, 1))
            If a0 = "U" And RegExTest(code, "^%u[0-9A-F]{4}") Then
                str = str & ChrW((Int("&H" & Mid(code, 3, 4))))
                code = Mid(code, 7)
            ElseIf a0 = "E" And RegExTest(code, "^(%[0-9A-F]{2}){3}") Then
                str = str & ChrW((Int("&H" & Mid(code, 2, 2)) And 15) * 4096 + (Int("&H" & Mid(code, 5, 2)) And 63) * 64 + (Int("&H" & Mid(code, 8, 2)) And 63))
                code = Mid(code, 10)
            ElseIf a0 >= "C" And a0 <= "D" And RegExTest(code, "^(%[0-9A-F]{2}){2}") Then
                str = str & ChrW((Int("&H" & Mid(code, 2, 2)) And 3) * 64 + (Int("&H" & Mid(code, 5, 2)) And 63))
                code = Mid(code, 7)
            ElseIf (a0 <= "B" Or a0 = "F") And RegExTest(code, "^%[0-9A-F]{2}") Then
                str = str & Chr(Int("&H" & Mid(code, 2, 2)))
                code = Mid(code, 4)
            Else
                str = str & "%"
                code = Mid(code, 2)
            End If
        Else
            str = str & code
            code = ""
        End If
    Wend
    URLDecode = str
End Function
'
 
Dernière édition:

scoubidou35

XLDnaute Occasionnel
Comment récupérer le texte d'un lien hypertext ?

Décodage de chaînes UTF-8 codées url dans VBScript
- https://newbedev.com/decoding-url-encoded-utf-8-strings-in-vbscript

Les codes d'encodage du caractère spécial « % » ou « pour cent ».
- https://outils-javascript.aliasdmc..../encode-caractere-0025-html-css-js-autre.html

VB:
Option Explicit

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)

If Range(Target.Address).Hyperlinks.Count > 0 Then
' Comment récupérer le texte d'un lien hypertext ?
' Colone 1 = Target.Value
' Colonne 2 = Target.Offset(0, 1).Value
    Target.Offset(0, 1).Value = Trim(Split(Target.Hyperlinks.Item(1).Address, "\")((UBound(Split(Target.Hyperlinks.Item(1).Address, "\")))))
'Liste pour remmplacer
               Target.Offset(0, 1).Value = Replace(Target.Offset(0, 1).Value, "%20", " ")
               Target.Offset(0, 1).Value = Replace(Target.Offset(0, 1).Value, "é", "é")
               Target.Offset(0, 1).Value = Replace(Target.Offset(0, 1).Value, "ê", "ê")
' REGEX (Fonction de conversion)
                Target.Offset(0, 1).Value = URLDecode(Target.Offset(0, 1).Value)  ' Target.Offset(0, 1).Value = sStr
End If
End Sub
'
'
' Fonction ci-dessous
Function RegExTest(str, patrn)
    Dim regEx As Object
        Set regEx = CreateObject("VBScript.RegExp")
    regEx.IgnoreCase = True
    regEx.Pattern = patrn
    RegExTest = regEx.test(str)
End Function
'
Function URLDecode(sStr)
' https://newbedev.com/decoding-url-encoded-utf-8-strings-in-vbscript
' Décodage de chaînes UTF-8 codées url dans VBScript
    Dim str, code, a0
    str = ""
    code = sStr
    code = Replace(code, "+", " ")
    While Len(code) > 0
        If InStr(code, "%") > 0 Then
            str = str & Mid(code, 1, InStr(code, "%") - 1)
            code = Mid(code, InStr(code, "%"))
            a0 = UCase(Mid(code, 2, 1))
            If a0 = "U" And RegExTest(code, "^%u[0-9A-F]{4}") Then
                str = str & ChrW((Int("&H" & Mid(code, 3, 4))))
                code = Mid(code, 7)
            ElseIf a0 = "E" And RegExTest(code, "^(%[0-9A-F]{2}){3}") Then
                str = str & ChrW((Int("&H" & Mid(code, 2, 2)) And 15) * 4096 + (Int("&H" & Mid(code, 5, 2)) And 63) * 64 + (Int("&H" & Mid(code, 8, 2)) And 63))
                code = Mid(code, 10)
            ElseIf a0 >= "C" And a0 <= "D" And RegExTest(code, "^(%[0-9A-F]{2}){2}") Then
                str = str & ChrW((Int("&H" & Mid(code, 2, 2)) And 3) * 64 + (Int("&H" & Mid(code, 5, 2)) And 63))
                code = Mid(code, 7)
            ElseIf (a0 <= "B" Or a0 = "F") And RegExTest(code, "^%[0-9A-F]{2}") Then
                str = str & Chr(Int("&H" & Mid(code, 2, 2)))
                code = Mid(code, 4)
            Else
                str = str & "%"
                code = Mid(code, 2)
            End If
        Else
            str = str & code
            code = ""
        End If
    Wend
    URLDecode = str
End Function
Bonsoir Laurent950
Merci j'ai copié les codes et cela fonctionne mais une fois que je protège la feuille en mettant unprotect en début de code et protect en fin du Worksheet_SelectionChange plus rien ne fonctionne je peux même pas ouvrir le lien comme si le code se reprotegeait avant d'avoir fini
 

laurent950

XLDnaute Accro
Bonsoir,
Je pense que la question : Comment récupérer le texte d'un lien hypertext est résolue.
- en Bonus le Décodage de chaînes UTF-8 codées url dans VBScript, a était aussi solutionné.
- Pour la protection de la Feuille --->>> il faut ouvrir un autre Poste.

Si la question initial de se poste à était résolu, pouvez vous noté le Numéro du Poste à Résolu

Puis ouvrir un autre poste pour trouver une solution à cette autre problème.

Merci à vous pour votre réponse @scoubidou35

Cdt
Laurent950
 

scoubidou35

XLDnaute Occasionnel
Bonjour à tous,
Je me suis aperçu que lorsque j'entre une nouvelle adresse celle-ci ne s'affichait que alléatoirement.
Je croyais que cela venait de la protection mais même sans j'avais toujours ce problème. Et en cherchant la solution à mon problème je me suis aperçu que cela fonctionnait quand je faisais un clique droit. Je pense que c'est lié à mon usage de :
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Mais du coup est ce qu'on peut intégrer les quelques lignes de code à la première partie (Private Sub Worksheet_SelectionChange(ByVal Target As Range) ? et si oui à quel niveau? Et comment faire pour si je supprime le lien hypertexte la colonne document s'efface également.
Merci et bonne journée
 

Discussions similaires

Réponses
7
Affichages
436
Réponses
5
Affichages
156
Réponses
2
Affichages
252