Mise en pièce jointe " avec référence target" de la cible d'un lien hypertexte

[corloste]

Bonjour,

Voilà je bute sur le problème suivant :
J'ai adapté une macro qui suite à un double clic dans une cellule génère un mail avec Outlook 2010. Dans l'objet et le corps du texte j'y ai intégré du texte fixe et complété ce texte avec des valeurs inscrites dans certaines cellules sur la même ligne que la cellule du double clic. Jusqu'ici tout va bien.
Mon souci c'est que je voudrais rajouter en pièce jointe la cible d'un lien hypertexte (qui peut être un fichier Word, pdf, odt ou autre fichier type traitement de texte) et ce lien est bien sur la même ligne que la cellule où on double click en target.cells(1, -1).

Voici le code :

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

'Teste si on double-clique dans la zone spécifié
If Not Application.Intersect(Target, Range("R3:R65000")) Is Nothing Then

'On enlève la protection
    ActiveSheet.Unprotect

'Si la cellule est ok on modifie son contenu
     If Target = "Double cliquez" Or Target = "" Then
        Target = Day(Now()) & "/" & Month(Now) & "/" & Year(Now())
        Target.Cells.Interior.ColorIndex = 44
        
        'Envoi du mail
        Dim ObjOutlook As New Outlook.Application
        Dim oBjMail
        Dim Nom_Fichier As String
   
        Set ObjOutlook = New Outlook.Application
        Set oBjMail = ObjOutlook.CreateItem(olMailItem)
    With oBjMail
        .To = ""      ' le destinataire
        .Subject = "Bla bla bla :" & " " & Target.Cells(1, -16).Value & " " & Target.Cells(1, -15) & " " & "/" & " " & Target.Cells(1, -9)    ' l'objet du mail
        .Body = "Bonjour," & Chr(13) & Chr(13) _
                & "Bla bla bla :" & " " & Target.Cells(1, -16) & " " & Target.Cells(1, -15) _
                & Chr(13) & "Référence :" & " " & Target.Cells(1, -14) _
                & Chr(13) & "Objet :" & " " & Target.Cells(1, -9) _
                & Chr(13) & Chr(13) & "Bla bla bla." _
                & Chr(13) & Chr(13) & "Argumentaire :" & " " & Target.Cells(1, 0) _
                & Chr(13) & Chr(13) & "Cordialement."
        .Attachments.Add ????????                  
        .Display  ' Afficher la fenêtre du mail pour vérification
    End With
        
        Set oBjMail = Nothing
        Set ObjOutlook = Nothing
    
    End If
   
    'On empeche l'entrée en mode édition pour la cellule cliquée
    Cancel = True
    'On remet la protection avec modification couleurs cellule
    ActiveSheet.Protect AllowFormattingCells:=True, AllowFormattingRows:=True, AllowFormattingColumns:=True
End If
End Sub

Et là je n'arrive pas à trouver ce qui faut mettre à la place des ????

Çà serait sympa de bien vouloir me donner un petit coup de pouce, j'ai beau éplucher le net (francophone) j'ai essayé plusieurs pistes mais rien ne va.

Merci.

 

[STephane]

Re : Mise en pièce jointe " avec référence target" de la cible d'un lien hypertexte

bonsoir

Voilà de quoi avancer.

Dim rng As Range
Set rng = ActiveCell
If rng.Hyperlinks.Count = 1 Then MsgBox rng.Hyperlinks(1).Address


bye

 

[corloste]

Re : Mise en pièce jointe " avec référence target" de la cible d'un lien hypertexte

Bonjour STephane,

Merci pour le tuyau, j'y suis presque... mais pas tout à fait.

Voilà comment j'ai adapté (je ne reprends pas tout le code):

 'Envoi du mail
        Dim ObjOutlook As New Outlook.Application
        Dim oBjMail
        Dim Nom_Fichier As String
        Dim rng as Range

        Set rng = Target.Cells(1, -1)
        Set ObjOutlook = New Outlook.Application
        Set oBjMail = ObjOutlook.CreateItem(olMailItem)
    With oBjMail
        .To = ""      ' le destinataire
        .Subject = "Bla bla bla :" & " " & Target.Cells(1, -16).Value & " " & Target.Cells(1, -15) & " " & "/" & " " & Target.Cells(1, -9)    ' l'objet du mail
        .Body = "Bonjour," & Chr(13) & Chr(13) _
                & "Bla bla bla :" & " " & Target.Cells(1, -16) & " " & Target.Cells(1, -15) _
                & Chr(13) & "Référence :" & " " & Target.Cells(1, -14) _
                & Chr(13) & "Objet :" & " " & Target.Cells(1, -9) _
                & Chr(13) & Chr(13) & "Bla bla bla." _
                & Chr(13) & Chr(13) & "Argumentaire :" & " " & Target.Cells(1, 0) _
                & Chr(13) & Chr(13) & "Cordialement."
            If rng.Hyperlinks.count = 1 Then
             .Attachments.Add rng.Hyperlinks(1).address
           End If                  
        .Display  ' Afficher la fenêtre du mail pour vérification
    End With
       
        Set oBjMail = Nothing
        Set ObjOutlook = Nothing
   
    End If

Et là je suis face à une erreur type "fichier introuvable, vérifiez le chemin d'accès et le nom de fichier"
Si je clic sur le débogage, puis sur la partie "rng.Hyperlinks(1).Address" en infobulle j'ai le chemin sous la forme :
rng.Hyperlinks(1).Address = ..\adresse.pdf
adresse.pdf est bien le nom du fichier mis en lien hypertexte, mais visiblement le chemin n'est pas entièrement reconnu.
D'autant que si à la place du .attachments je demande qu'il m'affiche un msgbox, l'adresse indiquée sur la msgbox est la même : ..\adresse.pdf

Aurais tu une autre piste à m'indiquer ?

En tous cas merci déjà pour la voie à suivre.

 

[corloste]

Re : Mise en pièce jointe " avec référence target" de la cible d'un lien hypertexte

Bonsoir,

Après vérification il s'agissait bien du bon code.
Si ce n'est que lorsque on créé un lien hypertexte, le chemin n'est pas entièrement indiqué, la boite de dialogue pour la création du lien affiche ..\"le nom du fichier" au lieu de l'adresse complète.
J'ai remplacé cette adresse par le chemin complet et là ça a bien fonctionné.

Je suis embêté car mon fichier s'adressant à plusieurs utilisateurs, je ne pourrais pas leur dire qu'il faut mettre le chemin complet dans la fenêtre de création du lien hypertexte, et le plus rageant c'est lorsqu'on met le pointeur de la souris sur le lien, l'infobulle indique le chemin complet même si c'est ..\"le nom du fichier" qui est inscrit dans la boite de dialogue.

Est-ce que quelqu'un aurait une solution pour ce blocage SVP ?
J'ai déjà essayé d'enlever le message d'avertissement des liens hypertexte en ajoutant une clé de registre mais cela ne change rien.

 

[STephane]

Re : Mise en pièce jointe " avec référence target" de la cible d'un lien hypertexte

bonjour,

si le classeur est toujours sur un lecteur de disque donné, tu peux essayer de mettre "c:\" ou "lecteur:\" dans la propriété "Répertoire Web" du fichier.

il y aussi un bricolage proposé là :
MS Excel 2003: Extract hyperlink address (files and web addresses)

 

[corloste]

Re : Mise en pièce jointe " avec référence target" de la cible d'un lien hypertexte

Bonjour,

Avec "lecteur:\" saisi dans le répertoire web du fichier, effectivement la fenêtre de saisie de l'adresse du lien hypertexte affiche bien le chemin complet, et la macro récupère donc bien l'adresse du lien.

J'ai essayé avec le "c:\" là le chemin repris est presque complet, mais il manque quand même la racine donc la macro ne trouve pas le fichier.

Un grand merci pour ces précieuses infos, et à bientôt.

 

[STephane]

Re : Mise en pièce jointe " avec référence target" de la cible d'un lien hypertexte

Amélioration de la fonction proposée dans le lien hypertexte pré-cité.
Bien sûr, il y a des limitations.

Function HyperLinkText2(pRange As Range) As String
' cette fonction peut être utilisée dans une formule
Dim ST1 As String
Dim ST2 As String
Dim LPath As String
Dim ST1Local As String


If pRange.Hyperlinks.Count = 0 Then
Exit Function
End If


LPath = ActiveWorkbook.FullName


ST1 = pRange.Hyperlinks(1).Address
ST2 = pRange.Hyperlinks(1).SubAddress


Const sBackwards = "..\"
Dim iSubstringCount As Long
iSubstringCount = SubstringCount(ST1, sBackwards)
ST1Local = ReturnPath(LPath, CLng(iSubstringCount)) & Mid(ST1, iSubstringCount * Len(sBackwards))


If ST2 <> "" Then
   ST1Local = "[" & ST1Local & "]" & ST2
End If


HyperLinkText2 = ST1Local
   
End Function




Function ReturnPath(pAppPath As String, pCount As Integer) As String


   Dim LPos As Integer
   Dim LTotal As Integer
   Dim LLength As Integer
   
   LTotal = 0
   LLength = Len(pAppPath)
   
   Do Until LTotal = pCount + 1
      If Mid(pAppPath, LLength, 1) = "\" Then
         LTotal = LTotal + 1
      End If
      LLength = LLength - 1
   Loop
   
   ReturnPath = Mid(pAppPath, 1, LLength)
   
End Function
Public Function SubstringCount(Chaine, substring) As Long
SubstringCount = UBound(Split(Chaine, substring))
End Function

 

[STephane]

Re : Mise en pièce jointe " avec référence target" de la cible d'un lien hypertexte

Une autre tentative.

Sub HyperLinkText3_DEMO()
MsgBox HyperLinkText3(ActiveCell)
End Sub


Function HyperLinkText3(pRange As Range) As String
' cette fonction peut être utilisée dans une formule


If pRange.Hyperlinks.Count = 0 Then
Exit Function
End If


Dim ST1$
ST1 = pRange.Hyperlinks(1).Address


Dim fso As Object
Dim vPath As Variant


' Attention,cela retourne le chemin relativement au répertoire courant
Set fso = CreateObject("Scripting.FileSystemObject")
vPath = fso.GetAbsolutePathName(ST1)
Debug.Print vPath
HyperLinkText3 = vPath
End Function

 

[corloste]

Re : Mise en pièce jointe " avec référence target" de la cible d'un lien hypertexte

Pour ma part je vais aller au plus simple, avec l'ajout de lecteur dans le répertoire web, vu que le fichier prendra en référence que des liens d'objets situés sur le même lecteur.

Mais ce sont des solutions à conserver au cas où, ou pour d'autres...

Cordialement.