XL 2016 Changer la présentation du lien hypertexte

[scoubidou35]

Bonjour à tous,

Je dois créer un fichier avec des liens hypertexte sauf qu'au lien d'avoir le liens avec l'adresse en bleu souligné j'aimerai avec un caractère spécial (webdings 158 = fiche doc).
Je sais le faire manuellement mais c'est un peu long donc je voulais savoir s'il est possible que dès que je crée un nouveau liens hypertexte dans le fichier j'obtienne directement le liens avec l'icone fiche comme dans l'exemple de mon fichier.
Merci

 

[sylvanu]

Bonjour Scoubidou,
Dans votre fichier il vous faut modifier le style des liens hypertexte :

Réglage de la taille par défaut de la police des liens hypertextes [Forums - Espace Débutants] : myDearFriend! Excel Pages

Utilitaires, tutoriels et astuces Excel - VBA par myDearFriend!

www.mdf-xlpages.com

En conclusion, il te faut maintenant changer les paramètres de ce style particulier et pour ce faire :
- ton classeur ouvert et actif.
- dans le ruban Excel, onglet Accueil, conteneur Style, tu cliques sur le bouton Styles de cellule,
- dans les styles présentés, tu fais un clic DROIT sur celui intitulé Lien hypertexte,
- et là, tu redéfinies le format souhaité,
- tu réenregistres ton document.

Ainsi tous les liens du fichier seront sous cette mise en forme.
NB : Dans le lien, dans le texte à afficher, il est peut être plus simple de mettre =car(158) au lieu de faire un copier coller du caractère.

 

[job75]

Bonjour scoubidou35, sylvanu,

La macro dans le code de la feuille :

Private Sub Worksheet_Change(ByVal Target As Range)
With [Tableau1].Columns(2) 'tableau structuré
    With .Font
        .Name = "Webdings"
        .Size = 24
        .Underline = xlUnderlineStyleNone
        .Color = RGB(47, 117, 181) 'bleu
    End With
    Set Target = Intersect(Target, .Cells)
End With
If Target Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each Target In Target 'si entrées multiples
    If Target.Hyperlinks.Count Then Target = Chr(158)
Next
Application.EnableEvents = True
End Sub

A+

 

[Valtrase]

Salut à tous
Ou encore...

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")
                ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=strLien _
                        , TextToDisplay:=Chr(158)
                    .Value = Chr(158)
                    .Font.Name = "Webdings"
                    .Font.Color = vbBlue
                    .Font.Size = 24
                    .Font.Underline = False
                End If
            End If
        End With
    End If
End Sub

 

[scoubidou35]

Bonsoir, Merci à vous trois pour vos propositions. Elles répondent exactement à ma demande et j'avoue que j'hésite dans mon choix entre la proposition de job 75 et celle de Valtrase. Je verrai cela demain à tête reposé.
Merci encore pour votre aide et du temps que vous me consacrez.
Bonne soirée

 

[Valtrase]

Salut à tous,
Scoubidou, ce n'est pas un concours, tu choisis celle qui correspond le mieux au résultat que tu attends puisqu'elles ne font pas exactement pareil ou mieux tu fais un mix. Comme je dis souvent nous sommes là pour vous aiguiller sur la bonne voie. Bonne prog.

 

[scoubidou35]

Salut à tous,
Scoubidou, ce n'est pas un concours, tu choisis celle qui correspond le mieux au résultat que tu attends puisqu'elles ne font pas exactement pareil ou mieux tu fais un mix. Comme je dis souvent nous sommes là pour vous aiguiller sur la bonne voie. Bonne prog.

Bonjour Valtrase et le forum,
Oui bien sûr, mais j'étais tellement content en voyant les 2 solutions et voir le temps que j'allais gagner comparé à ma méthode manuelle
et je vous remercie encore tous pour votre aide.

J'ai testé les 2 codes et lorsque je créé un lien pour accéder à un doc pdf qui à des accents sur les e et a dans le titre çà me mets d'autres chaines de caractère dans le lien hypertexte et donc impossible d'ouvrir le lien. J'ai bien sûr trouvé la méthode manuelle en allant dans modifier le lien hypertext et en effectuant les corrections mais y a t'il moyen de modifier le code pour faire la correction ? Sinon je demanderai au collègue de modifier les noms de leurs documents en supprimant tous les accents .
En tout cas merci encore à vous trois.

 

[job75]

Bonjour scoubidou35, Valtrase,

Chez moi sur Excel 2019 je n'ai pas constaté ce problème d'accents.

Notez que ma macro permet le copier-coller de plusieurs liens simultanément, pas celle de Valtrase.

A+

 

[scoubidou35]

Bonjour job75 et Valtrase,

en effet, je n'avais pas vu car j'ai testé en ne copiant que les liens un à un

Sinon Valtrase j'ai testé un peu plus votre code et je me suis aperçu que si je ne rentre pas d'adresse et que je fais clic sur annuler de l'inputbox cela me créé un lien malgré tout,
J'ai essayé d'intégré la réponse if vbcancel = false then exit sub mais ca ne fonctionne pas.
Pouvez vous me dire si c'est déjà le bon code et où je dois le mettre ? Merci
@+

 

[scoubidou35]

Bonjour à tous
J'avance très doucement j'ai modifié le code de Valtrase et maintenant si je clique sur le bouton annulé je sorts proprement. Mais, il me reste encore un problème si on clique sur OK sans avoir saisi de texte ca me créé une adresse "bidon" alors que souhaiterai rien mais je n'arrive pas à trouver. J'ai essayé en mettant la commande if strLien = "Saisir le texte" then exit sub mais ca ne fait rien.

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")
                On Error GoTo suite
               If strLien = False Then Exit Sub
suite:
               On Error GoTo 0

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

 

[Valtrase]

Salut Scoubidou,

Sinon Valtrase j'ai testé un peu plus votre code et je me suis aperçu que si je ne rentre pas d'adresse et que je fais clic sur annuler de l'inputbox cela me créé un lien malgré tout,
J'ai essayé d'intégré la réponse if vbcancel = false then exit sub mais ca ne fonctionne pas.
Pouvez vous me dire si c'est déjà le bon code et où je dois le mettre ? Merci

Tu as plusieurs façon de régler ton problème tout dépend de la finalité que tu veux. par exemple tu peux gérer la sortie de l'InputBox avec un Select Case

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
                            ActiveSheet.Hyperlinks.Add Anchor:=Selection, 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

Tu pourrais faire aussi une boucle Do While tant que le champ n'est pas renseigné.

J'ai testé les 2 codes et lorsque je créé un lien pour accéder à un doc pdf qui à des accents sur les e et a dans le titre çà me mets d'autres chaines de caractère dans le lien hypertexte et donc impossible d'ouvrir le lien. J'ai bien sûr trouvé la méthode manuelle en allant dans modifier le lien hypertext et en effectuant les corrections mais y a t'il moyen de modifier le code pour faire la correction ? Sinon je demanderai au collègue de modifier les noms de leurs documents en supprimant tous les accents .
En tout cas merci encore à vous trois.

Pour cela tu as cette fonction trouvée sur la toile:

Function RemoveCharAccents(ByVal TextToChange As String, Optional ByVal ToUpperCase As Boolean = False)
'Permet de substituer les accents d'un chaîne avec option MAJUSCULE
Const CHARS_WITH_ACCENTS As String = _
      "ÁÂÃÄÅÇÈÉÊËÌÍÎÏÑÒÓÔÕÖØÙÚÛÜÝàáâãäåçèéêëìíîïñòóôõöøùúûüýÿ"
'"ÀÁÂÃÄÅÈÉÊËÌÍÎÏÒÓÔÕÖØÙÚÛÜàáâãäåèéêëìíîïòóôõöøùúûüÿÑÇñç"
Const CHARS_WITHOUT_ACCENTS As String = _
      "AAAAACEEEEIIIINOOOOOUUUUYaaaaaaceeeeiiiinoooooouuuuyy"
'"AAAAAAEEEEIIIIOOOOOOOUUUUaaaaaaeeeeiiiioooooouuuuyNCnc"
Dim c As Integer
Dim strChar As String
Dim strNoAccentChars As String
Dim strFinalString As String

strFinalString = TextToChange
strNoAccentChars = CHARS_WITHOUT_ACCENTS
If ToUpperCase Then
    strNoAccentChars = UCase$(CHARS_WITHOUT_ACCENTS)
End If
For c = 1 To Len(CHARS_WITH_ACCENTS)
    strChar = Mid$(CHARS_WITH_ACCENTS, c, 1)

    If InStr(1, strFinalString, strChar, vbBinaryCompare) Then
        strFinalString = Replace(strFinalString, strChar, Mid$(strNoAccentChars, c, 1))
    End If
Next c
RemoveCharAccents = IIf(ToUpperCase, UCase(strFinalString), strFinalString)
End Function

Tu la colles dans un module et après tu peux l'appeler de la sorte.

If .Value = "" Then
                    strLien = RemoveCharAccents(Application.InputBox("Entrez le lien hypertexte.", "Insertion lien hypertexte", "Entrez le texte"))
                    
                    Select Case strLien
'...
'...