Outlook is not recongnized the email address when drafting mails through VBA

[Rajneesh Rawat]

Hi All,

I am facing a problem related to outlook Emails recognition.

I am drafting multiple mails in outlook through excel VBA and read the recipeints list from excel , however , I am getting delivery failed message when i send these mails as outlook is not able to recognized the email address.

One solution for this, I got is rather than drafting mails , display mails but this creates multiple windows on system.

Please suggest any alternative solution if anyone have.

Thanks

 

[Logit]

Post your code.

 

[Rajneesh Rawat]

'PO_Reminder

Dim BUname As String

Sub Execute(path As String, Emails As String)
'Application.DisplayAlerts = False
    Sheets("RoBo").Select
    
    If Right(path, 1) <> "\" Then
        path = path & "\"
    End If
      
    ActiveSheet.Range("A65000").End(xlUp).Select
    If ActiveCell.Row <> 1 Then
        ActiveSheet.Range(ActiveCell, Range("A2")).Select
        Selection.Delete shift:=xlUp
    End If
    Sheets("Dump").Select
    BUname = ActiveSheet.Range("A2").Value
    
    ActiveSheet.Range("A65000").End(xlUp).Select
    X = ActiveCell.Row
    ActiveSheet.Range("Z2:Z" & X).Select
    Selection.Copy
    Sheets("RoBo").Select
    ActiveSheet.Range("A2").Select
    ActiveCell.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
    Application.CutCopyMode = False
    ActiveSheet.Columns("A:A").Select
    ActiveSheet.Columns("A:A").RemoveDuplicates Columns:=1, Header:=xlYes
    y = ActiveSheet.Range("A65000").End(xlUp).Row
    i = 2
    While i <= y
        Cells(i, 1).Select
        If Cells(i, 1).Value = "" Then
            ActiveCell.Delete shift:=xlUp
            i = i - 1
            y = y - 1
        End If
        i = i + 1
    Wend

    Sheets("Dump").Select
    ActiveSheet.Columns("L:L").Select
    Selection.Insert shift:=xlToRight
    Selection.Insert shift:=xlToRight
    ActiveSheet.Range("L1").Value = "Date"
    ActiveSheet.Range("M1").Value = "Dif"
    ActiveSheet.Range("L2").Value = "=IF(K2<>"""",K2,J2)"
    ActiveSheet.Range("M2").Value = "=TEXT(NOW(),""mm/dd/yyyy"")-L2"
    ActiveSheet.Range("L2:M" & X).Select
    If X <> 2 Then
        Selection.FillDown
    End If
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
    Application.CutCopyMode = False
    ActiveSheet.Range("L2:L" & X).NumberFormat = "[$-409]d-mmm-yy;@"
    ActiveSheet.Range("M2:M" & X).NumberFormat = "0"

    ActiveSheet.Range("A2").Select

    For i = 2 To X Step 1
        ActiveSheet.Range("A" & i).Select
        If ActiveSheet.Range("M" & i).Value >= 180 Then
            Selection.EntireRow.Interior.Color = vbYellow
        Else
        If ActiveSheet.Range("M" & i).Value >= 60 And ActiveSheet.Range("M" & i).Value < 180 Then
            Selection.EntireRow.Interior.Color = RGB(244, 176, 132)
        End If
        End If
    Next
        
    'Sorting
    ActiveWorkbook.Worksheets("Dump").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Dump").Sort.SortFields.Add Key:=Range("Z2:Z" & X), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Dump").Sort.SortFields.Add Key:=Range("L2:L" & X), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Dump").Sort
        .SetRange Range("A1:AC" & X)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
ActiveSheet.Columns("L:M").Select
Selection.Delete shift:=xlToLeft

Workbooks.Add
ActiveWorkbook.SaveAs (path & "HSA.xlsx")
Set myfile = ActiveWorkbook

ThisWorkbook.Activate
' Filtering
    ActiveSheet.Range("A1:AC" & X).Select
    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$AC$" & X).AutoFilter Field:=8, Criteria1:="HSA"
    ActiveSheet.Range("A65000").End(xlUp).Select
    If ActiveCell.Row > 1 Then
        ActiveSheet.Range(ActiveCell, Range("Z1")).Select
        Selection.Copy
        myfile.Activate
        ActiveSheet.Paste
        Application.CutCopyMode = False
        ActiveSheet.Name = "HSA"
        Selection.EntireColumn.AutoFit
        ActiveSheet.Range("$A$1").Select
    End If
    myfile.Close savechanges:=True
    ThisWorkbook.Activate
    myfile = ""
    Workbooks.Add
    ActiveWorkbook.SaveAs (path & "Blank.xlsx")
    Set myfile = ActiveWorkbook
    
    ThisWorkbook.Activate
    ActiveSheet.Range("A1:AC" & X).Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
    ActiveSheet.Range("A2:AC" & X).Select
    ActiveSheet.ShowAllData
    ActiveSheet.Range("$A$1:$AC$" & X).AutoFilter Field:=26, Criteria1:=""
    ActiveSheet.Range("A65000").End(xlUp).Select
    If ActiveCell.Row > 1 Then
        ActiveSheet.Range(ActiveCell, Range("Z1")).Select
        Selection.Copy
        myfile.Activate
        ActiveSheet.Paste
        ActiveSheet.Name = "Blank"
        Selection.EntireColumn.AutoFit
        ActiveSheet.Range("A1").Select
        Application.CutCopyMode = False
    End If
    myfile.Close savechanges:=True
    ThisWorkbook.Activate
    
    co = 0
    Sheets("RoBo").Select
    ActiveSheet.Range("A2").Select
    
    While ActiveCell.Value <> ""
        Poc = ActiveCell.Value
        Sheets("Dump").Select
        Filename = BUname & " (" & Poc & ") Open & Unused PO's.xlsx"
        ActiveSheet.Range("A2:AC" & X).Select
        ActiveSheet.ShowAllData
        ActiveSheet.Range("$A$1:$AC$" & X).AutoFilter Field:=26, Criteria1:=Poc
        ActiveSheet.Range("A65000").End(xlUp).Select
        Get_To = ActiveSheet.Cells(Rows.Count, "AA").End(xlUp).Value
        If ActiveCell.Row > 1 Then
        co = co + 1
            Workbooks.Add
            ActiveWorkbook.SaveAs (path & Filename)
            Set myfile = ActiveWorkbook
            ThisWorkbook.Activate
            ActiveSheet.Range(ActiveCell, Range("Z1")).Select
            Selection.Copy
            myfile.Activate
            ActiveSheet.Paste
            ActiveSheet.Name = Poc
            Application.CutCopyMode = False
            Selection.EntireColumn.AutoFit
            ActiveSheet.Range("A1").Select
            myfile.Close savechanges:=True
        
        If Emails = "Yes" Then
            Dim outlookapp As Object
            Dim mitem As Object
            Set outlookapp = CreateObject("Outlook.Application")
            Set mitem = outlookapp.CreateItem(0)

              With mitem
                '.To = Poc
                .To = Get_To
                .cc = "ap@agencyacctgservices.com; mark.mcguire@agencyacctgservices.com"
                .Subject = Left(Filename, Len(Filename) - 5)
                .HTMLBody = "<HTML>****** style=font-size:11pt;font-family:Calibri>" & "Hi," & "<br>" & "<br>" & "Attached is a list of all open and unused PO's for your department(s)." & "<br>" & "<br>" & " - Yellow items are over 180 days past the expected receipt date.  Given the age, we will cancel them if no response to the contrary is received within 7 business days." & "<br>" & " - Orange items are 60-179 days past the expected receipt date. We ask that you review these and alert us if any should be cancelled, or contact the vendor to obtain the missing invoice." & "<br>" & " - Remaining items are newer, but either we have not received the approved PO or we have not received the invoice yet.  Please review these items as well and assist with processing as necessary." & "<br>" & "<br>" & "If you have any questions, please let us know." & "<br>" & "<br>" & "Thanks," & "<br>" & "Ashwin" & "</BODY></HTML>" & .HTMLBody
                .Attachments.Add path & Filename
'                .display
                .Save
                .Close olPromtForSave
              End With
        End If
        End If
        ThisWorkbook.Activate
        Sheets("RoBo").Select
        ActiveCell.Offset(1, 0).Select
    Wend
    Sheets("Dump").Select
    Selection.AutoFilter
    Sheets("RoBo").Select
    ActiveSheet.Range("A1").Select
    MsgBox "Files Exported sucessfully " & vbNewLine & vbNewLine & "Blank.xlsx - Have all the enteries without 'PO Coordinators'" & vbNewLine & "HSA.xlsx - have all the enteries with 'PO Type' as 'HSA' " & vbNewLine & "Total files exported sucessfully is : " & co & vbNewLine & vbNewLine & "Thanks for using the automation.                                              Created By : " & vbNewLine & "                                                                                                         Satish Kumar ", , "Job Completed ... "
Application.DisplayAlerts = True
End Sub

Sub Start()
Front.Show
End Sub

 

[Logit]

.
You are missing one line of code that tells VBA to send the emails :

With mitem
                '.To = Poc
                .To = Get_To
                .cc = "ap@agencyacctgservices.com; mark.mcguire@agencyacctgservices.com"
                .Subject = Left(Filename, Len(Filename) - 5)
                .HTMLBody = "<HTML>****** style=font-size:11pt;font-family:Calibri>" & "Hi," & "<br>" & "<br>" & "Attached is a list of all open and unused PO's for your department(s)." & "<br>" & "<br>" & " - Yellow items are over 180 days past the expected receipt date.  Given the age, we will cancel them if no response to the contrary is received within 7 business days." & "<br>" & " - Orange items are 60-179 days past the expected receipt date. We ask that you review these and alert us if any should be cancelled, or contact the vendor to obtain the missing invoice." & "<br>" & " - Remaining items are newer, but either we have not received the approved PO or we have not received the invoice yet.  Please review these items as well and assist with processing as necessary." & "<br>" & "<br>" & "If you have any questions, please let us know." & "<br>" & "<br>" & "Thanks," & "<br>" & "Ashwin" & "</BODY></HTML>" & .HTMLBody
                .Attachments.Add path & Filename
                '.display
[COLOR=#ff0000][B]                .Send '<---- this command[/B][/COLOR]
                .Save
                .Close olPromtForSave
              End With

I haven't tried to understand the remainder of your code ...

Here is a sample project that uses Col B for the email addresses. It can be edited to utilize Col A very easily :

Option Explicit




Sub eMail()
Dim lRow As Integer
Dim i As Integer
Dim toList As String
Dim eSubject As String
Dim eBody As String
Dim OutApp, OutMail As Object


With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .DisplayAlerts = False
End With


Sheets(1).Select [COLOR=#ff0000][B]'<--- Everything is located on Sheet1[/B][/COLOR]
[B][COLOR=#ff0000]lRow = Cells(Rows.Count, 2).End(xlUp).Row '<--- Change the number 2, to 1 if you want to use Col. A for the email addresses.[/COLOR][/B]
[B][COLOR=#ff0000]For i = 2 To lRow '<--- It begins looking from row Two and down the columns for the email addresses. This allows for a HEADER on the first row.[/COLOR][/B]


     Set OutApp = CreateObject("Outlook.Application")
     Set OutMail = OutApp.CreateItem(0)


        toList = Cells(i, 2)    'gets the recipient email address from col X
        eSubject = "This is your Subject"
        eBody = "Dear " & Cells(i, 1) & vbCrLf & vbCrLf & "Just a quick note to advise your VIP Client's status at the show." & vbCrLf & vbCrLf & vbCrLf & _
        "Sincerely, " & vbCrLf & vbCrLf & _
        "John Doe "
        
        On Error Resume Next
        With OutMail
        .To = toList
        .CC = ""
        .BCC = ""
        .Subject = eSubject
        .Body = eBody
        .Display   ' ********* Creates draft emails. Comment this out when you are ready
        '.Send     '********** UN-comment this when you  are ready to go live
        End With
        
        
    Application.Goto ActiveWorkbook.Sheets("Sheet1").Range("A1")


    On Error GoTo 0
    Set OutMail = Nothing
    Set OutApp = Nothing
 
Next i


With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .DisplayAlerts = True
End With
End Sub

 

[Rajneesh Rawat]

Thanks Logit for your response.

I will try it and let you know if i have anyother issue on this.