ADD LINK TO EMAIL TO OPEN|VBA & Macros|Excel Forum|My Online Training Hub

Hi,

Can this code below be modify that also in the spreadsheet link to email that can open it? much appreciated your help.

Option Explicit
Dim n As Long
Sub Launch_Pad()
Dim olApp As Outlook.Application
Dim olNS As Outlook.Namespace
Dim olFolder As Outlook.MAPIFolder
Dim Date1 As Date
Dim Date2 As Date
Dim Subject As String
Application.ScreenUpdating = False
Date1 = Range("J2").Value
Date2 = Range("K2").Value
Subject = Range("L2").Value

Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olFolder = olNS.PickFolder

Call ProcessFolder(olFolder, Subject, Date1, Date2)
Application.ScreenUpdating = True
Set olFolder = Nothing
Set olApp = Nothing
Set olNS = Nothing
End Sub

Sub ProcessFolder(olfdStart As Outlook.MAPIFolder, _
Subject As String, _
StartDate As Date, _
EndDate As Date)
Dim olObject As Object
Dim n As Long

n = 2

For Each olObject In olfdStart.Items

If TypeName(olObject) = "MailItem" Then

If Int(olObject.ReceivedTime) >= StartDate And Int(olObject.ReceivedTime) <= EndDate Then

If olObject.Subject Like "*" & Subject & "*" Then

Cells(n, 1).Value = olObject.Subject
If Not olObject.UnRead Then Cells(n, 2).Value = "Message is read" Else Cells(n, 2).Value = "Message is unread"
Cells(n, 3).Value = olObject.ReceivedTime
Cells(n, 4).Value = olObject.LastModificationTime
Cells(n, 5).Value = olObject.Body
Cells(n, 6).Value = olObject.SenderName
Cells(n, 7).Value = olObject.FlagRequest

n = n + 1
End If
End If
End If
Next

Set olObject = Nothing
End Sub
Sub Formatting()
Application.ScreenUpdating = False
Range("E3").Select
Range(Selection, Selection.End(xlDown)).Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Application.ScreenUpdating = True
End Sub

Sub DelLastRowCols()
Application.ScreenUpdating = False
Dim lastrow As Long
lastrow = Sheet1.Cells(Rows.Count, "A").End(xlUp).Row
Range("A3:G3" & lastrow).Select
Selection.Clear
Range("A2").Select
Application.ScreenUpdating = True
End Sub

Sub final()
Call DelLastRowCols
Call Launch_Pad
Call Formatting
End Sub

Thank you