gibbo1715
09-08-2005, 01:26 AM
Got tasked with making something at work and came up with the below that I think is quite useful.
It is simple but thought id post it here in case anyone else can benifit from the same idea
Basically I have a list of names in column A, i double click the name to generate an EMAIL about that person, that email is different dependant on the content of column E, The recipient name is in Column F. it also date stamps when the message was created as well in column G
I ve hard coded the body text of email message into my code here as thats what i needed
Hope someone finds this useful, if you think its worthy of a KB entry let me know and i ll submit it in the appropriate way
Cheers
Gibbo
***Remember to set a reference to outlook***
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'Variable declaration
Dim oApp As Object, _
oMail As Object
Dim Name As String
Dim Action As String
Dim Failedon As String
Dim RecipientsName As String
Dim Bodytext As String
' Remember to set a reference to the Microsoft Outlook Object
'Error Handling
On Error GoTo Err:
'Check active column is column 1 (Where you want the macro to be called from)
If ActiveCell.Column = 1 Then
Name = ActiveCell.Value
Action = ActiveCell.Offset(0, 1).Value
Details = ActiveCell.Offset(0, 2).Value
RecipientsName = ActiveCell.Offset(0, 5).Value
Select Case EmailMessage
Case ActiveCell.Offset(0, 4).Value = "With Me"
Bodytext = " This is Email 1"
Case ActiveCell.Offset(0, 4).Value = "With You"
Bodytext = " This is Email 2"
Case ActiveCell.Offset(0, 4).Value = ""
Exit Sub
End Select
'Create and show the outlook mail item 1
Set oApp = CreateObject("Outlook.Application")
Set oMail = oApp.CreateItem(0)
With oMail
'Mail To
.To = RecipientsName
'Subject Text
.Subject = "Ref: " & Name & " Action: " & Action
'Body Text
.Body = Bodytext
.Importance = olImportanceHigh
.ReadReceiptRequested = True
'use .Display to show the mail
.Display
End With
Set oMail = Nothing
Set oApp = Nothing
End If
Exit Sub
Err:
MsgBox "Sorry there has been an error, please contact an administrator"
Set oMail = Nothing
Set oApp = Nothing
End Sub
It is simple but thought id post it here in case anyone else can benifit from the same idea
Basically I have a list of names in column A, i double click the name to generate an EMAIL about that person, that email is different dependant on the content of column E, The recipient name is in Column F. it also date stamps when the message was created as well in column G
I ve hard coded the body text of email message into my code here as thats what i needed
Hope someone finds this useful, if you think its worthy of a KB entry let me know and i ll submit it in the appropriate way
Cheers
Gibbo
***Remember to set a reference to outlook***
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'Variable declaration
Dim oApp As Object, _
oMail As Object
Dim Name As String
Dim Action As String
Dim Failedon As String
Dim RecipientsName As String
Dim Bodytext As String
' Remember to set a reference to the Microsoft Outlook Object
'Error Handling
On Error GoTo Err:
'Check active column is column 1 (Where you want the macro to be called from)
If ActiveCell.Column = 1 Then
Name = ActiveCell.Value
Action = ActiveCell.Offset(0, 1).Value
Details = ActiveCell.Offset(0, 2).Value
RecipientsName = ActiveCell.Offset(0, 5).Value
Select Case EmailMessage
Case ActiveCell.Offset(0, 4).Value = "With Me"
Bodytext = " This is Email 1"
Case ActiveCell.Offset(0, 4).Value = "With You"
Bodytext = " This is Email 2"
Case ActiveCell.Offset(0, 4).Value = ""
Exit Sub
End Select
'Create and show the outlook mail item 1
Set oApp = CreateObject("Outlook.Application")
Set oMail = oApp.CreateItem(0)
With oMail
'Mail To
.To = RecipientsName
'Subject Text
.Subject = "Ref: " & Name & " Action: " & Action
'Body Text
.Body = Bodytext
.Importance = olImportanceHigh
.ReadReceiptRequested = True
'use .Display to show the mail
.Display
End With
Set oMail = Nothing
Set oApp = Nothing
End If
Exit Sub
Err:
MsgBox "Sorry there has been an error, please contact an administrator"
Set oMail = Nothing
Set oApp = Nothing
End Sub