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

S

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
laurent950
scoubidou35 à dit:
J'ai trouvé la cause j'ai fait le teste avec un pdf :
Cliquez pour agrandir...

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 =...
Trier par date Trier par votes
S

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
Vote positif 0 Vote négatif
laurent950

laurent950

XLDnaute Barbatruc
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:
Vote positif 0 Vote négatif
laurent950

laurent950

XLDnaute Barbatruc
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
 
Vote positif 0 Vote négatif
S

scoubidou35

XLDnaute Occasionnel
laurent950 à dit:
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
Cliquez pour agrandir...
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.
 
Vote positif 0 Vote négatif
laurent950

laurent950

XLDnaute Barbatruc
scoubidou35 à dit:
mais par contre je n'ai rien sur la colonne suivante.
Cliquez pour agrandir...
' 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
 
Vote positif 0 Vote négatif
S

scoubidou35

XLDnaute Occasionnel
laurent950 à dit:
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
Cliquez pour agrandir...
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
 
Vote positif 0 Vote négatif
laurent950

laurent950

XLDnaute Barbatruc
scoubidou35 à dit:
J'ai trouvé la cause j'ai fait le teste avec un pdf :
Cliquez pour agrandir...

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:
Vote positif 1 Vote négatif
Solution
laurent950

laurent950

XLDnaute Barbatruc
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:
Vote positif 0 Vote négatif
S

scoubidou35

XLDnaute Occasionnel
laurent950 à dit:
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
Cliquez pour agrandir...
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
 
Vote positif 0 Vote négatif
laurent950

laurent950

XLDnaute Barbatruc
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
 
Vote positif 0 Vote négatif
S

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
 
Vote positif 0 Vote négatif

Discussions similaires

J
  • Résolu(e)
Autres Partage fichier avec lien hypertexte
2
Réponses
20
Affichages
530
TooFatBoy
TooFatBoy
Cédric06400
  • Résolu(e)
Microsoft 365 Lien hyper tetxe email
Réponses
9
Affichages
157
TooFatBoy
TooFatBoy
J
  • Résolu(e)
XL 2021 Coloriser et décoloriser une cellule activée par lien hypertexte
3 4 5
Réponses
71
Affichages
2 K
JMC
J
kaine
  • Question
Microsoft 365 Importer données depuis un lien web
Réponses
1
Affichages
184
gbinforme
G
D
  • Résolu(e)
XL 2021 Créer feuilles automatiquement dans un classeur a partir d'une liste et lien hypertexte
Réponses
6
Affichages
391
Phil69970
Phil69970
S
  • Résolu(e)
Microsoft 365 Conserver lien hypertexte avec une fonction RechercheV
2
Réponses
19
Affichages
736
job75
job75
B
  • Question
Microsoft 365 Excel - Problème de macro
Réponses
7
Affichages
250
Benouze
B
F
  • Question
Microsoft 365 Récupérer l'userform parent d'un controle
2
Réponses
27
Affichages
561
Dranreb
Dranreb
P
  • Question
Microsoft 365 Calculer heures supplémentaires automatiquement selon pointage
Réponses
2
Affichages
129
Po-p0/59
P
R
  • Question
Microsoft 365 Fonction lien Hypertexte
Réponses
7
Affichages
699
job75
job75

Membres actuellement en ligne

14 membres et 253 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
314 656
Messages
2 111 610
Membres
111 221
dernier inscrit
Odré