Lien hypertexte Outlook par macro

Bonjour,

Je souhaite tout simplement ajouter un lien hypertexte dans mon mail qui s'enverra en automatique:

C'est le csPath1 qui devrait être sous lien hypertexte. J'ai essayé cette ligne qui ne fonctionne pas:

  Texte(1) = "Bonjour," & vbCr & vbCr & _
    "Pouvez-vous svp intégrer le CC KITS/SPARES et importer les BL:" & vbCr & vbCr & _
    "<a href=" & csPath1 & ">URL Text</A>" & vbCr & vbCr & "Merci," & vbCr & "Cordialement."

Code complet:

Option Explicit

Const olMailItem As Integer = 0
Const olImportanceHigh = 2

Sub SendToADV()
  Dim sDest As String, sCopie As String, Objet As String
  Dim Texte(2) As String
  Dim Cel As Range, Plage As Range
  Dim OutLk As Object, eMail As Object, Rng As Object, wdDoc As Object
  Dim Dlig As Long
  Dim csPath1 As String

  Application.ScreenUpdating = False

 csPath1 = "http://sp-is.lat.corp/SPDocs/DocsProgrammes/Programme PHS/KITS_SPARES_AIB Carnet de commande v2 (+div + iti) CP 157 165"

  Objet = "Mise à jour CC KITS/SPARES AIB"
  Texte(1) = "Bonjour," & vbCr & vbCr & _
    "Pouvez-vous svp intégrer le CC KITS/SPARES et importer les BL:" & vbCr & vbCr & csPath1 & vbCr & vbCr & "Merci," & vbCr & "Cordialement."

  ' eMails du/des destinataires et copie
  sDest = "jean@email.com"
  sCopie = "pierre@email.com;christophe@email.com"
  '
  ' Création de l'instance Outlook et de l'objet email
  Set OutLk = CreateObject("outlook.application")
  Set eMail = OutLk.CreateItem(olMailItem)

  With eMail
    .Display  ' ICI pour afficher la signature et la conserver
    .To = sDest
    .CC = sCopie
    .Subject = Objet
    .Importance = olImportanceHigh
    ' Corps du mail
    Set wdDoc = eMail.GetInspector.WordEditor
    Set Rng = wdDoc.Range(0, 0)
    ' Insertion avant la copie du tableau
    Rng.InsertAfter Texte(1) 'introduction
    .Send     'Envoyer le message
    End With
  ' On efface les variables objets
    ActiveWorkbook.Close SaveChanges:=True
  Set OutLk = Nothing: Set eMail = Nothing: Set wdDoc = Nothing

  Call EffacerTousLesFiltres

  Application.ScreenUpdating = True

End Sub

D'avance un grand merci :)

Bonne journée !

Bonjour,

Je vois que les lecteurs n'ont pas ma solution, je les remercie quand même d'avoir regardé :)

Par ce message je remonte mon sujet dans l'espoir de trouver preneur

Bonne journée à tout le monde !

Bonjour Anthony

Je n'ai aucun moyen de tester et je ne l'ai jamais fait, mais en cherchant ,j'ai trouvé cette syntaxe :

Texte(1) = "Bonjour," & vbCr & vbCr & _
    "Pouvez-vous svp intégrer le CC KITS/SPARES et importer les BL:" & vbCr & vbCr & _
    "<a href=""" & csPath1 & """>URL Text</A>" & vbCr & vbCr & "Merci," & vbCr & "Cordialement."

Je ne te promets rien, mais si cela ne va pas, cherche bien, il y a des exemples un peu partout, tu devrais trouver

Bon courage

Merci pour ta proposition mais malheureusement je l'avais trouvée sur la toile et testée.

Ca ne fonctionne pas non plus...

Bonjour Anthonydu31, Patty5046,

Voir d'après le lien ci-dessous en vert si cela fait avancer ta demande.

Email avec hypertexte: Lien

Bonjour à tous

Et comme cela ??

Texte(1) = "Bonjour," & vbCr & vbCr & _
    "Pouvez-vous svp intégrer le CC KITS/SPARES et importer les BL:" & vbCr & vbCr & _
    "<a href=""" & csPath1 & """</A>" & vbCr & vbCr & "Merci," & vbCr & "Cordialement."

Je cherche encore

Non plus :(

Re

Il semblerait que les espaces posent problème, car le lien s'arrête au premier espace de ton adresse.

Je suis sûre que l'on doit pouvoir y remédier, mais on approche de la solution.

Je n'aurai peut-être pas trop le temps de continuer, je pense que tu vas t'en sortir, ou quelqu'un va peut-être pouvoir prendre la suite

Je reviens

J'ai trouvé :

Texte (1) = "Bonjour," & vbCr & vbCr & _
    "Pouvez-vous svp intégrer le CC KITS/SPARES et importer les BL:" & vbCr & vbCr & _
    "<a href=""" & "<" & csPath1 & ">" & """</A>" & vbCr & vbCr & "Merci," & vbCr & "Cordialement."

En fait, il faut, quand il y a des espaces, mettre le nom du lien entre chevrons < et >

Bonne soirée

Pour moi ça ne fonctionne pas ça m'affiche cela dans le mail:

<a href="< PHS/KITS_SPARES_AIB Carnet de commande v2 (+div + iti) CP 157 165>"</A>

A nouveau,

Si cela ne fonctionne pas, c'est que ton lien n'est pas valide.

Réalise directement, donc sans passer par du code VBA, par Outlook un mail où tu intègre ton lien hypertexte dans le corps de celui-ci.

Puis lance ce lien même sans envoyer le mail , par exemple en mode brouillon. Et s'il n'aboutit pas, c'est qu'il bloquera aussi sur ton code VBA..

Bonjour Anthony, bonjour X Cellus

As-tu bien copié sans erreur ce que je t'ai donné, car je peux maintenant faire des tests et cela marche chez moi

J'obtiens

<a href="<http://sp-is.lat.corp/SPDocs/DocsProgrammes/Programme PHS/KITS_SPARES_AIB Carnet de comman...

Lorsque je met manuellement un lien hypertexte cela fonctionne.

Donc le problème est ailleurs

Bonjour,

Vous ne pouvez pas utiliser du HTML avec l'éditeur Word. Vous devez passer par l'ajout d'un lien. Comme ceci :

        Texte(1) = "Bonjour," & vbCr & vbCr & _
            "Pouvez-vous svp intégrer le CC KITS/SPARES et importer les BL:" & vbCr & vbCr
        rng.Move 4, 1
        rng.Text = Texte(1)
        rng.Move 4, 1
        wdDoc.Hyperlinks.Add rng, cspath1
        Texte(2) = vbCr & vbCr & "Merci," & vbCr & "Cordialement."
        rng.Move 4, 1
        rng.Text = Texte(2)

Par ailleurs, l'utilisation de l'éditeur Word nécessite qu'un explorateur Outlook soit actif sur votre PC. Ce chapelet d'instruction le vérifie et l'active sinon

    '// assignation application Outlook
    Set OutLk = CreateObject("Outlook.Application")
    If OutLk.Explorers.Count = 0 Then
        OutLk.Session.GetDefaultFolder(olFolderInbox).Display
        OutLk.ActiveExplorer.WindowState = olMinimized
    End If

Ok, j'ai ajouté comme ceci dans le code mais maintenant j'ai un msg d'erreur bloc with non défini sur la ligne Rng.Move 4, 1:

Option Explicit

Const olMailItem As Integer = 0
Const olImportanceHigh = 2

Sub SendToADV()
  Dim sDest As String, sCopie As String, Objet As String
  Dim Texte(2) As String
  Dim cel As Range, Plage As Range
  Dim OutLk As Object, eMail As Object, Rng As Object, wdDoc As Object
  Dim Dlig As Long
  Dim csPath1 As String

  Application.ScreenUpdating = False

 csPath1 = "http://sp-is.lat.corp/SPDocs/DocsProgrammes/Programme%20PHS/KITS_SPARES_AIB%20Carnet%20de%20commande%20v2%20(+div%20+%20iti)%20CP%20157%20165.xlsm"

  Objet = "Mise à jour CC KITS/SPARES AIB"
Texte(1) = "Bonjour," & vbCr & vbCr & _
            "Pouvez-vous svp intégrer le CC KITS/SPARES et importer les BL:" & vbCr & vbCr
        Rng.Move 4, 1
        Rng.Text = Texte(1)
        Rng.Move 4, 1
        wdDoc.Hyperlinks.Add Rng, csPath1
        Texte(2) = vbCr & vbCr & "Merci," & vbCr & "Cordialement."
        Rng.Move 4, 1
        Rng.Text = Texte(2)

  ' eMails du/des destinataires et copie
  sDest = ""
  sCopie = ";"
  '
   '// assignation application Outlook
    Set OutLk = CreateObject("Outlook.Application")
    If OutLk.Explorers.Count = 0 Then
        OutLk.Session.GetDefaultFolder(olFolderInbox).Display
        OutLk.ActiveExplorer.WindowState = olMinimized
    End If

  With eMail
    .Display  ' ICI pour afficher la signature et la conserver
    .To = sDest
    .CC = sCopie
    .Subject = Objet
    .Importance = olImportanceHigh
    ' Corps du mail
    Set wdDoc = eMail.GetInspector.WordEditor
    Set Rng = wdDoc.Range(0, 0)
    ' Insertion avant la copie du tableau
    Rng.InsertAfter Texte(1) 'introduction
    '.Send     'Envoyer le message
    .Display 'pour afficher le message
    End With
  ' On efface les variables objets
    'ActiveWorkbook.Close SaveChanges:=True
  Set OutLk = Nothing: Set eMail = Nothing: Set wdDoc = Nothing

  Call EffacerTousLesFiltres

  Application.ScreenUpdating = True

End Sub
Public Sub EffacerTousLesFiltres()
On Error Resume Next
  Dim fc As Worksheet
  For Each fc In ActiveWorkbook.Worksheets
    If fc.FilterMode = True Then
      fc.ShowAllData
    End If
  Next fc
End Sub

Option Explicit

Const olMailItem As Integer = 0
Const olImportanceHigh = 2

Sub SendToADV()
  Dim sDest As String, sCopie As String, Objet As String
  Dim Texte(2) As String
  Dim cel As Range, Plage As Range
  Dim OutLk As Object, eMail As Object, Rng As Object, wdDoc As Object
  Dim Dlig As Long
  Dim csPath1 As String

  Application.ScreenUpdating = False

 csPath1 = "http://sp-is.lat.corp/SPDocs/DocsProgrammes/Programme%20PHS/KITS_SPARES_AIB%20Carnet%20de%20commande%20v2%20(+div%20+%20iti)%20CP%20157%20165.xlsm"

  Objet = "Mise à jour CC KITS/SPARES AIB"
  Texte(1) = "Bonjour," & vbCr & vbCr & _
            "Pouvez-vous svp intégrer le CC KITS/SPARES et importer les BL:" & vbCr & vbCr
  Texte(2) = vbCr & vbCr & "Merci," & vbCr & "Cordialement."

  ' eMails du/des destinataires et copie
  sDest = "jean@email.com"
  sCopie = "pierre@email.com;christophe@email.com"
  '
   '// assignation application Outlook
    Set OutLk = CreateObject("Outlook.Application")
    If OutLk.Explorers.Count = 0 Then
        OutLk.Session.GetDefaultFolder(olFolderInbox).Display
        OutLk.ActiveExplorer.WindowState = olMinimized
    End If

  With eMail
    .Display  ' ICI pour afficher la signature et la conserver
    .To = sDest
    .CC = sCopie
    .Subject = Objet
    .Importance = olImportanceHigh
    ' Corps du mail
    Set wdDoc = eMail.GetInspector.WordEditor
    Set Rng = wdDoc.Range(0, 0)
    ' Insertion avant la copie du tableau
        Rng.Move 4, 1
        Rng.Text = Texte(1)
        Rng.Move 4, 1
        wdDoc.Hyperlinks.Add Rng, csPath1
        Rng.Move 4, 1
        Rng.Text = Texte(2)
    '.Send     'Envoyer le message
    .Display 'pour afficher le message
    End With
  ' On efface les variables objets
    'ActiveWorkbook.Close SaveChanges:=True
  Set OutLk = Nothing: Set eMail = Nothing: Set wdDoc = Nothing

  Call EffacerTousLesFiltres

  Application.ScreenUpdating = True

End Sub

Ok, même message avec la ligne en erreur:

 .Display  ' ICI pour afficher la signature et la conserver

Il vous manque l'instruction de création du mail

..................
   '// assignation application Outlook
    Set OutLk = CreateObject("Outlook.Application")
    If OutLk.Explorers.Count = 0 Then
        OutLk.Session.GetDefaultFolder(olFolderInbox).Display
        OutLk.ActiveExplorer.WindowState = olMinimized
    End If

  Set eMail = OutLk.CreateItem(olMailItem)
  With eMail
    .Display  ' ICI pour afficher la signature et la conserver
............................

Super ça semble fonctionner, merci :)

Dernier réglage d'ordre cosmétique, le "Merci, Cordialement" s'imbrique dans ma signature...

Modifier Texte(2) en rajoutant deux sauts de ligne après "Cordialement."

        Texte(2) = vbCr & vbCr & "Merci," & vbCr & "Cordialement." & vbCr & vbCr