Envoie d'un mail contenant un lien hypertext

Bonjour,

Je suis débutant sur VBA et je vous fais un appelle au secoure car j'ai reçu une demande de modification d'un fichier excel comportant justement du VBA.

Le but de ce fichier excel est de simplifier une action quotidienne (l'envoi de rapport), à l'heure actuelle nous sommes obligé tous les soirs de rédiger un long mail contenant toutes les infos ce qui nous fait perdre un temps précieux.

Nous avons donc commencé et même bien avancé sur ce fichier excel.

Mais désormais nous bloquons sur un point important nos rapports comportent un lien hypertext qui lorsque nous faisons le copier coller dans le fichier excel fonctionne encore et qui lorsque nous le transférons vers nos mails pour ensuite l'envoyer ne fonctionne plus.

Pourquoi ?

Nous ne savons pas et c'est donc pour cela que nous avons besoin de votre aide, vous trouverez notre code juste en dessous.

Merci par avance.

Private Sub Validate_Click()
    Application.ScreenUpdating = False
    'timeNow = Format(Now, "yy-mm-dd hh:mm")
    If Sheets("TODAY'S ALERTS").Range("A4") = "Paste the incidents and requests starting from this cell" Then
        'NOTHING
    ElseIf Sheets("TODAY'S ALERTS").Range("A4") = "" Then
        'NOTHING
    Else
        timenow = Now
        ActiveSheet.Unprotect "Projet"
        ActiveWorkbook.Unprotect "Projet"

        '' Copying data from first sheet to the mail one
            Sheets("TODAY'S ALERTS").Select
                Range("A2").Value = "Blablabla" & localtimezone & " shift"
                Range("A1").Select
                    Position = ActiveCell.Row
                    lastRowToday = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
                Range("A4:G" & lastRowToday).Select
                    Selection.Copy

        '' Emailing
            Dim rng As Range
            Dim OutApp As Object
            Dim OutMail As Object

            Sheets("TODAY'S ALERTS").Select
            Range("A2:G" & lastRowToday).Select
            Set rng = Selection.SpecialCells(xlCellTypeVisible)

            Dim xObjIs, xObjI
            Set xObjIs = GetObject("winmgmts:\\.\root\cimv2").ExecQuery("Select * From Win32_TimeZone")
                For Each xObjI In xObjIs
                    GetTimeZoneAtPresent = xObjI.Caption
                Next

            AMAS = InStr(GetTimeZoneAtPresent, "Pacific")
            EMEA = InStr(GetTimeZoneAtPresent, "Paris")
            ASPA = InStr(GetTimeZoneAtPresent, "Bangkok")
            If AMAS = 0 Then
                If EMEA = 0 Then
                    If ASPA = 0 Then
                        localtimezone = "undefined TZ"
                    Else
                        localtimezone = "VIETNAMESE"
                    End If
                Else
                    localtimezone = "FRENCH"
                End If
            Else
                localtimezone = "AMERICAN"
            End If

            Set OutApp = CreateObject("Outlook.Application")
            Set OutMail = OutApp.CreateItem(0)
            With OutMail
                .To = "123@test.com"
                .Cc = "456@test.com"
                .BCC = "789@test.com"
                .Subject = "Bonjour" & localtimezone & "test" & timenow
                .HTMLBody = "<p style='font-family:calibri;font-size:15'>" & "Corp du message" & RangetoHTML(rng)

                .Display
            End With
            'Set OutMail = Nothing
            'Set OutApp = Nothing

            Sheets("123").Select
            Range("A2").Value = "456" & localtimezone & " shift"
            Range("A4:G" & lastRowToday).EntireRow.Delete

            Range("A4").Value = "789"
            Sheets("test").Range("A4").Select

            ActiveSheet.Protect "Projet", True, True, True, AllowInsertingHyperlinks:=True
            ActiveWorkbook.Protect Password:="Test", structure:=True
            'ActiveWorkbook.SaveAs "C:\Program Files\WindowsPowerShell" & ActiveWorkbook.Name
            ThisWorkbook.Save
            'source_file = ThisWorkbook.FullName
            source_file = "C:\Program Files\WindowsPowerShell" & ActiveWorkbook.Name
            'OutMail.Attachments.Add source_file

            Set OutMail = Nothing
            Set OutApp = Nothing
    End If

End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

End Sub

Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook

    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

    'Copy the range and create a new workbook to past the data in
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With

    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With

    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")

    'Close TempWB
    TempWB.Close savechanges:=False

    'Delete the htm file we used in this function
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

'Sub PasteAsValue()
'    Selection.PasteSpecial Paste:=xlPasteValues
'End Sub