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

 '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

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

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