Option Explicit 
 
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, _ 
    Cancel As Boolean) 
    Dim sName       As String 
    Dim sAction     As String 
    Dim sDetails    As String 
    Dim sMeYou      As String 
    Dim sTo         As String 
    Dim sBody       As String 
    Dim bSucces     As Boolean 
     
     'Error Handling
    On Error Goto Err_Mail 
     
     'Check active column is column 1 (Where you want the macro to be called from)
    If Target.Column = 1 Then 
        With Target 
            sName = .Value 
            sAction = .Offset(0, 1).Value 
            sDetails = .Offset(0, 2).Value 
            sMeYou = .Offset(0, 4).Value 
            sTo = .Offset(0, 5).Value 
        End With 
         'Stop update mode in cell
        Cancel = True 
    Else 
         'Cancel sub if not column 1 and goto update mode
        Cancel = False 
        Exit Sub 
    End If 
     
     'Set mailoptions depending on value of sMeYou and create email
    If sMeYou = "With Me" Then 
        bSucces = CreateMailItem(sTo, "This is email 1", sDetails, _ 
        sName, sAction, 2, True) 
         
    ElseIf sMeYou = "With You" Then 
        bSucces = CreateMailItem(sTo, "This Is email 2", sDetails, _ 
        sName, sAction, 2, True) 
    End If 
     
     ' If mail was created fillin maildate
    If bSucces Then 
        Target.Offset(0, 6).Value = Now() 
    Else 
        MsgBox "MailItem could not be created" 
    End If 
     
    Exit Sub 
     
Err_Mail: 
    MsgBox "Sorry there has been an error, please contact an administrator" 
End Sub 
 
 'Function to display email item with various options
Public Function CreateMailItem(sTo As String, _ 
    sBody As String, _ 
    sDetails As String, _ 
    sName As String, _ 
    sAction As String, _ 
    iImportance As Integer, _ 
    bReceipt As Boolean) As Boolean 
    Dim oOutlookApp  As Object 
    Dim oOutlookMail As Object 
    CreateMailItem = False 
     
    On Error Resume Next 
     'Use current Outlook app if running
     'After pressing send the mail is send right away
    Set oOutlookApp = GetObject(, "Outlook.Application") 
     
     'Not running create a new instance of Outlook
    If Err <> 0 Then 
         'After pressing send the email wil stay in Outbox til you open
         'Outlook again and press send receive
        Set oOutlookApp = CreateObject("Outlook.Application") 
    End If 
     'Create and show the outlook mail item
    If Not oOutlookApp Is Nothing Then 
        Set oOutlookMail = oOutlookApp.CreateItem(0) 
        If Not oOutlookMail Is Nothing Then 
            With oOutlookMail 
                 'Mail To
                .To = sTo 
                 'Subject Text
                .Subject = "Ref: " & sName & "          Action: " & sAction 
                 'Body Text
                .Body = sBody & vbCr & sDetails 
                 'Importance level
                .Importance = iImportance 
                 'Receipt yes or no
                .ReadReceiptRequested = bReceipt 
                 'use .Display to show the mail
                .Display 
                CreateMailItem = True 
            End With 
        End If 
    End If 
     
     'Clean up
    Set oOutlookMail = Nothing 
    Set oOutlookApp = Nothing 
End Function