Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

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
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

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

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
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

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
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

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

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
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

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
Identifiez-vous ou inscrivez-vous pour participer.

Discussions similaires

J
  • Résolu(e)
Autres Partage fichier avec lien hypertexte
2
Réponses
20
Affichages
782
TooFatBoy
  • Résolu(e)
Microsoft 365 Lien hyper tetxe email
Réponses
9
Affichages
202
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
J
  • Question
XL 2021 Créer liens hypertexte automatiquement
2
Réponses
21
Affichages
597
JMC
J
L
  • Question
Microsoft 365 recherche X lien entre 2 fichiers
Réponses
3
Affichages
194
lilie17
L
  • Question
Microsoft 365 Importer données depuis un lien web
Réponses
1
Affichages
239
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
494
Phil69970
S
  • Résolu(e)
Microsoft 365 Conserver lien hypertexte avec une fonction RechercheV
2
Réponses
19
Affichages
899
job75
  • Question
XL 2010 Bizarrerie Dans le VBE
Réponses
4
Affichages
210
cp4
B
  • Question
Microsoft 365 Excel - Problème de macro
Réponses
7
Affichages
313
Benouze
B
Menu
Connexion
S'inscrire
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…