Discussion :

[Souriane]

Bonjour,

De deux choses l'une :
Est-ce qu'il existe déjà un code VBA "tout fait" pour transformer en hyperlien l'adresse courriel sur lequel se trouve actuellement le curseur?

Sinon, j'en ai débuté un ci-dessous. Il fait le travail très bien, en autant qu'on ait pré-sélectionné l'adresse. J'aimerais ne pas avoir à sélectionner le courriel. Mais voilà, je ne sais pas comment m'y prendre car le courriel peut être sur une ligne seule, donc pas d'espace avant ou après, alors je ne peux pas utiliser cette méthode

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Selection.Extend Character:=" "

il peut contenir des points dans comme ceci mon.nom.tomate@compagnie.com, alors je ne peux pas utiliser cette méthode :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Selection.MoveRight Unit:=wdWord, count:=3, Extend:=wdExtend

De plus, je veux pouvoir mettre le curseur n'importe où dans l'adresse, pas nécessairement au début.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
Sub gCourrielHyperlien()
'Transforme une adresse de courriel en hyperlien cliquable
 
Selection.Copy
 
Dim MaDonnees As DataObject
Dim strClip As String
 
Set MaDonnees = New DataObject
MaDonnees.GetFromClipboard
strClip = MaDonnees.GetText
 
ActiveDocument.Hyperlinks.Add Anchor:=Selection.Range, Address:= _
"mailto:" & strClip, SubAddress:="", ScreenTip:="", _
TextToDisplay:=strClip
 
 
End Sub

Merci de votre aide!

Souriane

[Souriane]

Toujours à la recherche d'une solution... si jamais... Merci!

[mromain]

Bonjour Souriane, le forum,

Voici un bout de code qui permet d’étendre la sélection tant qu’il n’y a pas d’espaces.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
Sub Test()
 
Dim rngSelection As Word.Range
 
    'récupérer le premier mot sélectionné
    On Error Resume Next
     Set rngSelection = Selection.Range.Words(1)
    On Error GoTo 0
    If rngSelection Is Nothing Then Stop   'si arrêt ici, c'est que la sélection n'est pas sur un mot
 
    'étendre la sélection vers la gauche jusqu'à tomber sur un espace
    While (Not rngSelection Like " *") And (rngSelection.Start > rngSelection.Paragraphs(1).Range.Start)
        rngSelection.Start = rngSelection.Start - 1
    Wend
    If rngSelection Like " *" Then rngSelection.Start = rngSelection.Start + 1
    'étendre la sélection vers la droite jusqu'à tomber sur un espace
    While (Not rngSelection Like "* ") And (rngSelection.End < rngSelection.Paragraphs(1).Range.End)
        rngSelection.End = rngSelection.End + 1
    Wend
    If rngSelection Like "* " Then rngSelection.End = rngSelection.End - 1
 
    'sélectionner la zone résultat
    rngSelection.Select
 
End Sub

A+

[MauNic2]

Bonjour,
si vous définissez un signet à l'endroit où est l'adresse mail, il suffit alors de la sélectionner par code avec la ligne suivante :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

    Selection.GoTo what:=wdGoToBookmark, Name:="AdresseClient"

AdresseClient étant le nom du signet

[Souriane]

Voici un bout de code qui permet d’étendre la sélection tant qu’il n’y a pas d’espaces.

Je n'appellerais pas ça un "bout de code", j'appelle ça le code au complet!!! Gros merci. Votre code ajouté à mon code = résultat impécable!

Mille merci! Je suis comblée!

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
Sub TransformerCourrielEnHyperlien()
 
Dim rngSelection As Word.Range
 
    'récupérer le premier mot sélectionné
    On Error Resume Next
     Set rngSelection = Selection.Range.Words(1)
    On Error GoTo 0
    If rngSelection Is Nothing Then Stop   'si arrêt ici, c'est que la sélection n'est pas sur un mot
 
    'étendre la sélection vers la gauche jusqu'à tomber sur un espace
    While (Not rngSelection Like " *") And (rngSelection.Start > rngSelection.Paragraphs(1).Range.Start)
        rngSelection.Start = rngSelection.Start - 1
    Wend
    If rngSelection Like " *" Then rngSelection.Start = rngSelection.Start + 1
    'étendre la sélection vers la droite jusqu'à tomber sur un espace
    While (Not rngSelection Like "* ") And (rngSelection.End < rngSelection.Paragraphs(1).Range.End)
        rngSelection.End = rngSelection.End + 1
    Wend
    If rngSelection Like "* " Then rngSelection.End = rngSelection.End - 1
 
    'sélectionner la zone résultat
    rngSelection.Select
 
 
    Selection.Copy
 
Dim MaDonnees As DataObject
Dim strClip As String
 
Set MaDonnees = New DataObject
MaDonnees.GetFromClipboard
strClip = MaDonnees.GetText
 
ActiveDocument.Hyperlinks.Add Anchor:=Selection.Range, Address:= _
"mailto:" & strClip, SubAddress:="", ScreenTip:="", _
TextToDisplay:=strClip
 
 
End Sub

Souriane

[mromain]

Bonjour Souriane, MauNic2, le forum,

Mille merci! Je suis comblée!

Avec plaisir !

Ton code peut être simplifié ainsi :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
Sub TransformerCourrielEnHyperlien()
Dim rngSelection As Word.Range
 
    'récupérer le premier mot sélectionné
    On Error Resume Next
     Set rngSelection = Selection.Range.Words(1)
    On Error GoTo 0
    If rngSelection Is Nothing Then Stop   'si arrêt ici, c'est que la sélection n'est pas sur un mot
 
    'étendre la sélection vers la gauche jusqu'à tomber sur un espace
    While (Not rngSelection Like " *") And (rngSelection.Start > rngSelection.Paragraphs(1).Range.Start)
        rngSelection.Start = rngSelection.Start - 1
    Wend
    If rngSelection Like " *" Then rngSelection.Start = rngSelection.Start + 1
    'étendre la sélection vers la droite jusqu'à tomber sur un espace
    While (Not rngSelection Like "* ") And (rngSelection.End < rngSelection.Paragraphs(1).Range.End)
        rngSelection.End = rngSelection.End + 1
    Wend
    If rngSelection Like "* " Then rngSelection.End = rngSelection.End - 1
    If rngSelection Like "*." Then rngSelection.End = rngSelection.End - 1
 
    'si la valeur resemble à une adresse mail
    If rngSelection.Text Like "?*@*?.?*" Then
        'ajouter l'hyperlien "mailto"
        rngSelection.Document.Hyperlinks.Add rngSelection, "mailto:" & rngSelection.Text
    End If
 
End Sub

Cela évite la manipulation du presse-papier.

A+