Page 1 of 2 12 LastLast
Results 1 to 10 of 12

Thread: Need a vba macro which can send mail for particular status

  1. #1
    Junior Member
    Join Date
    Aug 2011
    Posts
    10
    Rep Power
    0

    Need a vba macro which can send mail for particular status

    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
    Attached Files Attached Files

  2. #2
    Administrator Excel Fox's Avatar
    Join Date
    Mar 2011
    Posts
    1,402
    Rep Power
    10
    Raja,

    Welcome to ExcelFox.

    Can you explain where the mail IDs are listed?
    A dream is not something you see when you are asleep, but something you strive for when you are awake.

    It's usually a bad idea to say that something can't be done.

    The difference between dream and aim, is that one requires soundless sleep to see and the other requires sleepless efforts to achieve

    Join us at Facebook

  3. #3
    Junior Member
    Join Date
    Aug 2011
    Posts
    10
    Rep Power
    0
    Quote Originally Posted by Excel Fox View Post
    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
    Attached Files Attached Files
    Last edited by rajasekhar; 11-01-2011 at 10:08 AM.

  4. #4
    Junior Member
    Join Date
    Aug 2011
    Posts
    10
    Rep Power
    0
    Please provide the solution its bit urgent. and sorry for troubling .

  5. #5
    Administrator Excel Fox's Avatar
    Join Date
    Mar 2011
    Posts
    1,402
    Rep Power
    10
    Will provide a solution, but the contact list only has names, no email ids...
    A dream is not something you see when you are asleep, but something you strive for when you are awake.

    It's usually a bad idea to say that something can't be done.

    The difference between dream and aim, is that one requires soundless sleep to see and the other requires sleepless efforts to achieve

    Join us at Facebook

  6. #6
    Junior Member
    Join Date
    Aug 2011
    Posts
    10
    Rep Power
    0
    using the company codes we need to pull the contact person names.

  7. #7
    Administrator Excel Fox's Avatar
    Join Date
    Mar 2011
    Posts
    1,402
    Rep Power
    10
    Which is fine, but where do we get the mail ids from? would you rather Outlook resolve the names?
    A dream is not something you see when you are asleep, but something you strive for when you are awake.

    It's usually a bad idea to say that something can't be done.

    The difference between dream and aim, is that one requires soundless sleep to see and the other requires sleepless efforts to achieve

    Join us at Facebook

  8. #8
    Junior Member
    Join Date
    Aug 2011
    Posts
    10
    Rep Power
    0
    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
    Last edited by rajasekhar; 11-01-2011 at 11:49 PM.

  9. #9
    Junior Member
    Join Date
    Aug 2011
    Posts
    10
    Rep Power
    0
    hi experts please reply my query

  10. #10
    Administrator Excel Fox's Avatar
    Join Date
    Mar 2011
    Posts
    1,402
    Rep Power
    10
    Here's the attachment along with the VBA Code.

    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_UseExcelObjectModeltoSendMailPart2_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
    Attached Files Attached Files
    A dream is not something you see when you are asleep, but something you strive for when you are awake.

    It's usually a bad idea to say that something can't be done.

    The difference between dream and aim, is that one requires soundless sleep to see and the other requires sleepless efforts to achieve

    Join us at Facebook

Similar Threads

  1. Replies: 12
    Last Post: 12-10-2019, 09:56 PM
  2. Replies: 5
    Last Post: 06-11-2013, 08:15 PM
  3. Automatically send Birthday E-Mail in Outlook
    By s.ajay88 in forum Outlook Help
    Replies: 2
    Last Post: 03-12-2013, 06:28 PM
  4. Outlook Send Mail With Multiple Recipient and CC
    By noobtron in forum Excel Help
    Replies: 2
    Last Post: 10-31-2012, 07:14 PM
  5. Send Mail Using VBA In Excel And Attach Files
    By macenmin in forum Excel Help
    Replies: 1
    Last Post: 08-03-2012, 01:03 AM

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •