Need a vba macro which can send mail for particular status

[rajasekhar]

hi Experts,



I have summary sheet in which for one particular status in column D if any status Begins and ends with Out of Scope - Out of Scope
Then it should using the company codes in column c send the mail to user in outlook along with variance amount which is found in E column



Mail format should be as follows.

Hi Users,

There is variance in between company codes -------- for the amount -------

Please fix this as soon as possible.

Thanks,
Gopal

[Excel Fox]

Raja,

Welcome to ExcelFox.

Can you explain where the mail IDs are listed?

[rajasekhar]

Raja,

Welcome to ExcelFox.

Can you explain where the mail IDs are listed?

its in contact list complete i attached the same please find it.

let me tell you in brief i have three columns out of which if i have status with Out of scope - Out of scope in column d for example D7 in Data work book in summary sheet which is attached in earlier post.

i need to take the company codes copied from column C 2053 & 1063
And pull the user mail ids from contact list and also pick the amount from D column and send the mail to user in this format

Hi User,

There is discrepancy between Company codes 2035 & 1063 with a variance of 289

Please fix this as soon as possible.

Thanks,
Raj

[rajasekhar]

Please provide the solution its bit urgent. and sorry for troubling .

[Excel Fox]

Will provide a solution, but the contact list only has names, no email ids...

[rajasekhar]

using the company codes we need to pull the contact person names.

[Excel Fox]

Which is fine, but where do we get the mail ids from? would you rather Outlook resolve the names?

[rajasekhar]

once we find the status as out of scope - out of scope then we need to take the company codes listed in C column and using this company codes need to do vlookup to get the mail contacts from contact list.

i hope it is clear now . please let me know if it is not clear.

Sorry to request once again as i running short of time. i am posting once again .

is there any way to speak to u so that i can communicate directly

[rajasekhar]

hi experts please reply my query

[Excel Fox]

Here's the attachment along with the VBA Code.



Option Explicit

'Ensure that you select the Microsoft Outlook X.0 Object Library in the references
'Outlook needs to be loaded, and account logged in

Sub CallMailer()

Dim lngLoop As Long 'Programming ethics 1. Always start your first line after leaving a line space, and 1 indentation level
Dim wksSummary As Worksheet
Dim wbkContact As Workbook
Dim strContact As String
Dim varCompCode As Variant
Dim strVariance As String
Dim lngCodes As Long

strContact = Application.GetOpenFilename("Excel 2007-10 Files (*.xlsx), *.xlsx", , "Select the contact list workbook", , False)
If strContact <> "False" Then
Set wbkContact = Workbooks.Open(strContact, False, True)
strContact = vbNullString
Else
Exit Sub
End If

With ThisWorkbook.Worksheets("Summary")
For lngLoop = 2 To .Cells(Rows.Count, "D").End(xlUp).Row
If .Cells(lngLoop, "D").Value = "Out of Scope - Out of Scope" Then
varCompCode = Split(Trim(Replace(.Cells(lngLoop, "C").Value, " ", "")), "&")
strVariance = Abs(CLng(.Cells(lngLoop, "E").Value))
For lngCodes = LBound(varCompCode) To UBound(varCompCode)
On Error Resume Next
strContact = strContact & wbkContact.Sheets("Sheet1").UsedRange.Find(What:=varCompCode(lngCodes), LookAt:=xlWhole).Offset(, 1).Value & ", "
If Err.Number Then
strContact = Left(strContact, Len(strContact) - 2)
End If
Err.Clear: On Error GoTo -1: On Error GoTo 0
Next lngCodes
If Right(strContact, 2) = ", " Then
strContact = Left(strContact, Len(strContact) - 2)
End If
Call SendMessage(strTo:=strContact, strMessage:=MsgToBeSent(strVariance, .Cells(lngLoop, "C").Value), strSubject:="Discrepancy Status Update")
End If
Next lngLoop
End With 'Programming ethics 2. Always end your last line leaving a line space before ending the sub or function, and having indendation level of 1

End Sub

Sub SendMessage(strTo As String, Optional strCC As String, Optional strBCC As String, Optional strSubject As String, Optional strMessage As String, Optional strAttachmentPath As String, Optional rngToCopy As Range, Optional blnShowEmailBodyWithoutSending As Boolean = False)

Dim objOutlook As Object 'Outlook.Application
Dim objOutlookMsg As Object 'Outlook.MailItem
Dim objOutlookRecip As Object 'Outlook.Recipient
Dim objOutlookAttach As Object 'Outlook.Attachment

If Trim(strTo) & Trim(strCC) & Trim(strBCC) = "" Then
MsgBox "Please provide a mailing address!", vbInformation + vbOKOnly, "Missing mail information"
Exit Sub
End If
' Create the Outlook session.
On Error Resume Next
Set objOutlook = GetObject(, "Outlook.Application")
Err.Clear: On Error GoTo -1: On Error GoTo 0
If objOutlook Is Nothing Then
Set objOutlook = CreateObject("Outlook.Application")
End If

' Create the message.
Set objOutlookMsg = objOutlook.CreateItem(0)

With objOutlookMsg
' Add the To recipient(s) to the message.
If Trim(strTo) <> "" Then
Set objOutlookRecip = .Recipients.Add(strTo)
objOutlookRecip.Type = 1 'olTO
End If

' Add the CC recipient(s) to the message.
If Trim(strCC) <> "" Then
Set objOutlookRecip = .Recipients.Add(strCC)
objOutlookRecip.Type = 2 'olCC
End If

' Add the BCC recipient(s) to the message.
If Trim(strBCC) <> "" Then
Set objOutlookRecip = .Recipients.Add(strBCC)
objOutlookRecip.Type = 3 'olBCC
End If

' Set the Subject, Body, and Importance of the message.
If strSubject = "" Then
strSubject = "This is an Automation test with Microsoft Outlook"
End If
.Subject = strSubject
If strMessage = "" Then
strMessage = "This is the body of the message." & vbCrLf & vbCrLf
End If
.Importance = 2 'High importance
If Not strMessage = "" Then
.Body = strMessage & vbCrLf & vbCrLf
End If
If Not rngToCopy Is Nothing Then
.HTMLBody = .Body & RangetoHTML(rngToCopy)
End If

' Add attachments to the message.
If Not strAttachmentPath = "" Then
If Len(Dir(strAttachmentPath)) <> 0 Then
Set objOutlookAttach = .Attachments.Add(strAttachmentPath)
Else
MsgBox "Unable to find the specified attachment. Sending mail anyway."
End If
End If

' Resolve each Recipient's name.
For Each objOutlookRecip In .Recipients
objOutlookRecip.Resolve
Next

' Should we display the message before sending?
If blnShowEmailBodyWithoutSending Then
.Display
Else
.Display
.Save
.Send
End If
End With

Set objOutlook = Nothing
Set objOutlookMsg = Nothing
Set objOutlookAttach = Nothing
Set objOutlookRecip = Nothing

End Sub

'http://msdn.microsoft.com/en-us/library/ff519602(v=office.11).aspx#odc_office_UseExcelObje ctModeltoSendMailPart2_MailingRangeSelectionBody
Function RangetoHTML(rng As Range)

' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010.
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 workbook to receive the data.
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 an .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 the RangetoHTML subroutine.
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.
Kill TempFile

Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing

End Function

Function MsgToBeSent(strVariance As String, strCompCode As String)

Dim str As String

str = "Hi Users,"
str = str & vbNewLine & ""
str = str & vbNewLine & "There is variance in between company codes " & strCompCode & " for the amount " & strVariance
str = str & vbNewLine & ""
str = str & vbNewLine & "Please fix this as soon as possible."
str = str & vbNewLine & ""
str = str & vbNewLine & "Thanks,"
str = str & vbNewLine & "NameHere"
MsgToBeSent = str

End Function

[rajasekhar]

hi ,

i am facing reference error please help me i configured by going into excel vba tools reference selected micros softoutlook.12 object.

i use excel 2007 please advise what i need to configure if i am wrong anywhere.
thanks for your help in advance.

[rajasekhar]

can some one please guide me in this concern macro is executing but getting error.